Changeset 1204
- Timestamp:
- Jun 23, 2011, 3:01:41 PM (14 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 3 added
- 44 edited
-
C0CACTOR.m (modified) (1 diff)
-
C0CALERT.m (modified) (1 diff)
-
C0CBAT.m (modified) (1 diff)
-
C0CCCD.m (modified) (1 diff)
-
C0CCCD1.m (modified) (1 diff)
-
C0CCCR.m (modified) (1 diff)
-
C0CCCR0.m (modified) (1 diff)
-
C0CCMT.m (modified) (1 diff)
-
C0CCPT.m (modified) (2 diffs)
-
C0CDOM.m (modified) (6 diffs)
-
C0CDPT.m (modified) (1 diff)
-
C0CENC.m (modified) (1 diff)
-
C0CEVC.m (added)
-
C0CEWD.m (modified) (1 diff)
-
C0CFM1.m (modified) (1 diff)
-
C0CFM2.m (modified) (1 diff)
-
C0CIM2.m (modified) (1 diff)
-
C0CIMMU.m (modified) (1 diff)
-
C0CIN.m (modified) (1 diff)
-
C0CLA7Q.m (modified) (1 diff)
-
C0CLABS.m (modified) (1 diff)
-
C0CMAIL2.m (added)
-
C0CMED.m (modified) (1 diff)
-
C0CMED1.m (modified) (1 diff)
-
C0CMED2.m (modified) (1 diff)
-
C0CMED3.m (modified) (1 diff)
-
C0CMIME.m (modified) (11 diffs)
-
C0CMXML.m (modified) (1 diff)
-
C0CMXMLB.m (modified) (2 diffs)
-
C0CMXP.m (modified) (1 diff)
-
C0CNHIN.m (modified) (4 diffs)
-
C0CNMED4.m (added)
-
C0CPARMS.m (modified) (1 diff)
-
C0CPROBS.m (modified) (1 diff)
-
C0CPROC.m (modified) (1 diff)
-
C0CRIMA.m (modified) (1 diff)
-
C0CRNF.m (modified) (1 diff)
-
C0CRXN.m (modified) (1 diff)
-
C0CSOAP.m (modified) (1 diff)
-
C0CSUB1.m (modified) (1 diff)
-
C0CSYS.m (modified) (1 diff)
-
C0CUNIT.m (modified) (1 diff)
-
C0CUTIL.m (modified) (1 diff)
-
C0CVA200.m (modified) (1 diff)
-
C0CVIT2.m (modified) (1 diff)
-
C0CXPAT0.m (modified) (1 diff)
-
C0CXPATH.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/C0CACTOR.m
r770 r1204 1 C0CACTOR 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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.0;C0C;;May 19, 2009;Build 38 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/trunk/p/C0CALERT.m
r666 r1204 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.0;C0C;;May 19, 2009; 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":"418634005",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 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ACVUID 84 . I ACVUID'="" D ; IF VUID IS NOT NULL 85 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="VUID" 86 . E D ; IF REACTANT CODE VALUE IS NULL 87 . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS 88 . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; 89 . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! 90 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" 91 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" 92 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW 93 . N ARTMP,ARIEN,ARDES,ARVUID 94 . S (ARTMP,ARDES,ARVUID)="" 95 . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS 96 . . S ARTMP=@ALTG@(ALTTMP,"S",1) 97 . . W "REACTION:",ARTMP,! 98 . . S ARIEN=$P(ARTMP,";",2) 99 . . S ARDES=$P(ARTMP,";",1) 100 . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") 101 . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES 102 . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL 103 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID 104 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" 105 . E D ; IF IT IS NULL DON'T SET CODE SYSTEM 106 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" 107 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" 108 . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) 109 . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION 110 . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL 111 . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME 112 . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") 113 . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") 114 . K @ALTARYTMP 115 . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) 116 . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) 117 . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) 118 . S ALTCNT=ALTCNT+1 119 S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS 120 Q 121 PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER 122 ; INGLB IS OF THE FORM: PSNDF(50.6, 123 ; RETURN 50.6 124 Q $P($P(INGLB,"(",2),",",1) ; 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 . I ACVUID'="" D ; IF VUID IS NOT NULL 85 . . S ZC=$$CODE^C0CUTIL(ACVUID) 86 . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 87 . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 88 . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 89 . E D ; IF REACTANT CODE VALUE IS NULL 90 . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS 91 . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; 92 . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! 93 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" 94 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" 95 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD 96 . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS 97 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD 98 . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD 99 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW 100 . N ARTMP,ARIEN,ARDES,ARVUID 101 . S (ARTMP,ARDES,ARVUID)="" 102 . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS 103 . . S ARTMP=@ALTG@(ALTTMP,"S",1) 104 . . W "REACTION:",ARTMP,! 105 . . S ARIEN=$P(ARTMP,";",2) 106 . . S ARDES=$P(ARTMP,";",1) 107 . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") 108 . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES 109 . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL 110 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID 111 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" 112 . E D ; IF IT IS NULL DON'T SET CODE SYSTEM 113 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" 114 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" 115 . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) 116 . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION 117 . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL 118 . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME 119 . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") 120 . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") 121 . K @ALTARYTMP 122 . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) 123 . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) 124 . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) 125 . S ALTCNT=ALTCNT+1 126 S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS 127 Q 128 PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER 129 ; INGLB IS OF THE FORM: PSNDF(50.6, 130 ; RETURN 50.6 131 Q $P($P(INGLB,"(",2),",",1) ; -
ccr/trunk/p/C0CBAT.m
r572 r1204 1 1 C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 23 STOP ; STOP A CURRENTLY RUNNING BATCH JOB 24 25 26 27 28 29 30 31 32 33 34 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 35 START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION 36 37 38 39 40 41 42 43 44 45 46 47 48 49 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 50 EN ; BATCH ENTRY POINT 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 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 148 BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME 149 150 151 152 153 154 155 156 157 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 158 COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS 159 160 161 162 163 164 165 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 166 UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 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 188 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 189 190 191 192 193 194 195 196 197 198 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 199 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 200 201 202 203 204 205 206 207 208 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 209 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 210 211 212 213 214 215 216 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 217 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 218 219 220 221 222 223 224 225 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 226 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 227 228 229 230 231 232 233 234 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/trunk/p/C0CCCD.m
r508 r1204 1 1 C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 23 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 25 26 27 28 29 30 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 31 XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 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 51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT 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 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 148 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 149 150 151 152 153 154 155 156 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 157 SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT 158 159 160 161 162 163 164 165 166 167 168 169 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 170 UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE 171 172 173 174 175 176 177 178 179 180 181 182 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 183 HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 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 202 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 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 227 TEST ; RUN ALL THE TEST CASES 228 229 230 228 D TESTALL^C0CUNIT("C0CCCR") 229 Q 230 ; 231 231 ZTEST(WHICH) ; RUN ONE SET OF TESTS 232 233 234 235 236 232 N ZTMP 233 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 234 D ZTEST^C0CUNIT(.ZTMP,WHICH) 235 Q 236 ; 237 237 TLIST ; LIST THE TESTS 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 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/trunk/p/C0CCCD1.m
r508 r1204 1 1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 25 ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array 26 27 28 29 30 31 32 33 34 35 36 37 38 39 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 40 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 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 60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME 61 62 63 64 61 D ZLOAD(ARY,"C0CCCD1") 62 ; ZWR @ARY 63 Q 64 ; 65 65 TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD 66 66 Q 67 67 MARKUP ;<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 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/trunk/p/C0CCCR.m
r974 r1204 1 1 C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 23 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 25 26 27 28 29 30 31 XPAT(DFN,XPARMS,DIR,FN) 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 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,XPARMS,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 CCRGLO,UDIR,UFN 35 S C0CNRPC=1 ; FLAG FOR NOT AN RPC CALL - FOR DEBUGGING THE RPC 36 I '$D(DIR) S UDIR="" 37 E S UDIR=DIR 38 I '$D(FN) S UFN="" ; IF FILENAME IS NOT PASSED 39 E S UFN=FN 40 I '$D(XPARMS) S XPARMS="" 41 N C0CRTN ; RETURN ARRAY 42 D CCRRPC(.C0CRTN,DFN,XPARMS,"CCR") 43 S OARY=$NA(^TMP("C0CCUR",$J,DFN,"CCR",1)) 44 S ONAM=UFN 45 I UFN="" S ONAM="PAT_"_DFN_"_CCR_V1_0_0.xml" 46 S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) 47 S ^TMP("C0CCCR","FNAME",DFN)=ONAM ; FILE NAME FOR BATCH USE 48 I $D(^TMP("GPLCCR","ODIR")) S @ODIRGLB=^TMP("GPLCCR","ODIR") 49 I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET 50 . W "Warning.. please set ^TMP(""C0CCCR"",""ODIR"")=""output path""",! Q 51 . ;S @ODIRGLB="/home/glilly/CCROUT" 52 . ;S @ODIRGLB="/home/cedwards/" 53 . S @ODIRGLB="/opt/wv/p/" 54 S ODIR=UDIR 55 I UDIR="" S ODIR=@ODIRGLB 56 N ZY 57 S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) 58 W !,$P(ZY,U,2),! 59 Q 60 ; 61 61 DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED 62 63 64 65 66 67 68 69 62 ; 63 N G1 64 S G1=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) 65 I $D(@G1@(0)) D ; CCR EXISTS 66 . D PARY^C0CXPATH(G1) 67 E W "CCR NOT CREATED, RUN D XPAT^C0CCCR(DFN,"""","""") FIRST",! 68 Q 69 ; 70 70 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT 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 71 ; CCRGRTN IS RETURN ARRAY PASSED BY REFERENCE 72 ; DFN IS PATIENT IEN 73 ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART 74 ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC 75 ; CCRPARMS ARE PARAMETERS THAT AFFECT THE EXTRACTION 76 ; IN THE FORM "PARM1:VALUE1^PARM2:VALUE2" 77 ; EXAMPLE: "LABLIMIT:T-60" TO LIMIT LAB EXTRACTION TO THE LAST 60 DAYS 78 ; SEE C0CPARMS FOR A COMPLETE LIST OF SUPPORTED PARAMETERS 79 K ^TMP("C0CCCR",$J) ; CLEAN UP THE GLOBAL BEFORE WE USE IT 80 M ^TMP("C0CSAV",$J)=^TMP($J) ; SAVING CALLER'S TMP SETTINGS 81 K ^TMP($J) ; START CLEAN 82 I '$D(DEBUG) S DEBUG=0 83 S CCD=0 ; NEED THIS FLAG TO DISTINGUISH FROM CCD 84 I '$D(CCRPARMS) S CCRPARMS="" 85 I '$D(CCRPART) S CCRPART="CCR" 86 I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"CALL",DFN)="" 87 D SET^C0CPARMS(CCRPARMS) ;SET PARAMETERS WITH CCRPARMS AS OVERRIDES 88 I '$D(TESTVIT) S TESTVIT=0 ; FLAG FOR TESTING VITALS 89 I '$D(TESTLAB) S TESTLAB=0 ; FLAG FOR TESTING RESULTS SECTION 90 I '$D(TESTALERT) S TESTALERT=1 ; FLAG FOR TESTING ALERTS SECTION 91 I '$D(TESTMEDS) S TESTMEDS=0 ; FLAG FOR TESTING C0CMED SECTION 92 S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE 93 S CCRGLO=$NA(^TMP("C0CCUR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR 94 S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS 95 ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC 96 ;M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART OR ALL 97 D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE 98 D CP^C0CXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL 99 ; 100 ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL 101 ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES 102 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") 103 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") 104 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") 105 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! 106 ; 107 D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES 108 ; 109 K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT 110 S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS 111 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS 112 N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD 113 F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS 114 . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE 115 . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL 116 . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL 117 . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE 118 . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS 119 . S IXML="INXML" 120 . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES 121 . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY 122 . ; W OXML,! 123 . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL 124 . W "RUNNING ",CALL,! 125 . X CALL 126 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 127 . I $G(@OXML@(0))>0 D ; THERE IS A RESULT 128 . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") 129 . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! 130 N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING 131 D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST 132 D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") 133 D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") 134 D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 135 K ACTT,ACTT2 136 D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") 137 D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") 138 D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") 139 K CMTT,CMTT2 140 N TRIMI,J,DONE S DONE=0 141 F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE 142 . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS 143 . I DEBUG W "TRIMMED",J,! 144 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE 145 ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL 146 I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR 147 E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART 148 I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" 149 K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP 150 K ^TMP($J) ; REALLY CLEAN UP 151 M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J 152 Q 153 ; 154 154 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 155 156 157 158 159 160 161 162 163 164 165 166 167 168 155 ; TAB IS PASSED BY NAME 156 I DEBUG W "TAB= ",TAB,! 157 ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS 158 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") 159 I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") 160 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") 161 D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") 162 I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 163 E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 164 D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") 165 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") 166 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 167 Q 168 ; 169 169 HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT 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 170 N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) 171 ; K @VMAP 172 S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") 173 ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS 174 D ; ALWAYS MAP THESE VARIABLES 175 . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR 176 . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 177 . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER 178 . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? 179 . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM 180 . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES 181 . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES 182 . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES 183 . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 184 ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED 185 ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY 186 N CTMP 187 D MAP^C0CXPATH(CXML,VMAP,"CTMP") 188 D CP^C0CXPATH("CTMP",CXML) 189 N HRIMVARS ; 190 S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS 191 M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE 192 S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT 193 Q 194 ; 195 195 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 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 196 ; AXML AND ACTRTN ARE PASSED BY NAME 197 ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 198 ; P1= OBJECTID - ACTORPATIENT_2 199 ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE 200 ;OR INSTITUTION 201 ; OR PERSON(IN PATIENT FILE IE NOK) 202 ; P3= IEN RECORD NUMBER FOR ACTOR - 2 203 N I,J,K,L 204 K @ACTRTN ; CLEAR RETURN ARRAY 205 F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS 206 . I @AXML@(I)?.E1"_<".E D ; 207 . . N ZA,ZB 208 . . S ZA=$P(@AXML@(I),">",1)_">" 209 . . S ZB="<"_$P(@AXML@(I),"<",3) 210 . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB 211 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 212 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR THIS LINE 213 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 214 . . I $G(LINKDEBUG) W "<ActorID>=>",J,! 215 . . I J'="" S K(J)="" ; HASHING ACTOR 216 . I @AXML@(I)?.E1"<LinkID>".E D ; THERE IS AN ACTOR THIS LINE 217 . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1) 218 . . I $G(LINKDEBUG) W "<LinkID>=>",J,! 219 . . I J'="" S K(J)="" ; HASHING ACTOR 220 . . ; TO GET RID OF DUPLICATES 221 S I="" ; GOING TO $O THROUGH THE HASH 222 F J=0:0 D Q:$O(K(I))="" 223 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 224 . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID 225 . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE 226 . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR 227 . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY 228 Q 229 ; 230 230 TEST ; RUN ALL THE TEST CASES 231 232 233 231 D TESTALL^C0CUNIT("C0CCCR") 232 Q 233 ; 234 234 ZTEST(WHICH) ; RUN ONE SET OF TESTS 235 236 237 238 239 235 N ZTMP 236 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 237 D ZTEST^C0CUNIT(.ZTMP,WHICH) 238 Q 239 ; 240 240 TLIST ; LIST THE TESTS 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 241 N ZTMP 242 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 243 D TLIST^C0CUNIT(.ZTMP) 244 Q 245 ; 246 ;;><TEST> 247 ;;><PROBLEMS> 248 ;;>>>K C0C S C0C="" 249 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") 250 ;;>>?@C0C@(@C0C@(0))["</Problems>" 251 ;;><VITALS> 252 ;;>>>K C0C S C0C="" 253 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") 254 ;;>>?@C0C@(@C0C@(0))["</VitalSigns>" 255 ;;><CCR> 256 ;;>>>K C0C S C0C="" 257 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 258 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 259 ;;><ACTLST> 260 ;;>>>K C0C S C0C="" 261 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 262 ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") 263 ;;><ACTORS> 264 ;;>>>D ZTEST^C0CCCR("ACTLST") 265 ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") 266 ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") 267 ;;>>?G3(G3(0))["</Actors>" 268 ;;><TRIM> 269 ;;>>>D ZTEST^C0CCCR("CCR") 270 ;;>>>W $$TRIM^C0CXPATH(CCRGLO) 271 ;;><ALERTS> 272 ;;>>>S TESTALERT=1 273 ;;>>>K C0C S C0C="" 274 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") 275 ;;>>?@C0C@(@C0C@(0))["</Alerts>" 276 277 -
ccr/trunk/p/C0CCCR0.m
r781 r1204 1 C0CCCR0 2 ;;1.0;C0C;;May 19, 2009;Build 32 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 907 908 909 910 911 912 913 914 915 916 917 1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 ;;<IDs> 795 ;;<Type> 796 ;;<Text>@@IDTYPE@@</Text> 797 ;;</Type> 798 ;;<ID>@@ID@@</ID> 799 ;;<IssuedBy> 800 ;;<Description> 801 ;;<Text>@@IDDESC@@</Text> 802 ;;</Description> 803 ;;</IssuedBy> 804 ;;</IDs> 805 ;;<Specialty> 806 ;;<Text>@@ACTORSPECIALITY@@</Text> 807 ;;</Specialty> 808 ;;<Address> 809 ;;<Type> 810 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 811 ;;</Type> 812 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 813 ;;<City>@@ACTORADDRESSCITY@@</City> 814 ;;<State>@@ACTORADDRESSSTATE@@</State> 815 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 816 ;;</Address> 817 ;;<Telephone> 818 ;;<Value>@@ACTORTELEPHONE@@</Value> 819 ;;<Type> 820 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 821 ;;</Type> 822 ;;</Telephone> 823 ;;<Email> 824 ;;<Value>@@ACTOREMAIL@@</Value> 825 ;;</Email> 826 ;;<Source> 827 ;;<Actor> 828 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 829 ;;</Actor> 830 ;;</Source> 831 ;;<InternalCCRLink> 832 ;;<LinkID>@@ACTORORGLINK@@</LinkID> 833 ;;<LinkRelationship>representedOrganization</LinkRelationship> 834 ;;</InternalCCRLink> 835 ;;</Actor> 836 ;;</ACTOR-PROVIDER> 837 ;;<ACTOR-ORG> 838 ;;<Actor> 839 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 840 ;;<Organization> 841 ;;<Name>@@ORGANIZATIONNAME@@</Name> 842 ;;</Organization> 843 ;;<Address> 844 ;;<Type> 845 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 846 ;;</Type> 847 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 848 ;;<City>@@ACTORADDRESSCITY@@</City> 849 ;;<State>@@ACTORADDRESSSTATE@@</State> 850 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 851 ;;</Address> 852 ;;<Telephone> 853 ;;<Value>@@ACTORTELEPHONE@@</Value> 854 ;;<Type> 855 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 856 ;;</Type> 857 ;;</Telephone> 858 ;;<Source> 859 ;;<Actor> 860 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 861 ;;</Actor> 862 ;;</Source> 863 ;;</Actor> 864 ;;</ACTOR-ORG> 865 ;;</Actors> 866 ;;<Signatures> 867 ;;<CCRSignature> 868 ;;<SignatureObjectID>S0001</SignatureObjectID> 869 ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime> 870 ;;<Source> 871 ;;<ActorID>AA0001</ActorID> 872 ;;</Source> 873 ;;<Signature> 874 ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#"> 875 ;;<SignedInfo> 876 ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/> 877 ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/> 878 ;;<Reference URI=""> 879 ;;<Transforms> 880 ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/> 881 ;;</Transforms> 882 ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/> 883 ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue> 884 ;;</Reference> 885 ;;</SignedInfo> 886 ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue> 887 ;;<KeyInfo> 888 ;;<KeyValue> 889 ;;<RSAKeyValue> 890 ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus> 891 ;;<Exponent>AQAB</Exponent> 892 ;;</RSAKeyValue> 893 ;;</KeyValue> 894 ;;</KeyInfo> 895 ;;</Signature> 896 ;;</Signature> 897 ;;</CCRSignature> 898 ;;</Signatures> 899 ;;<Comments> 900 ;;<Comment> 901 ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID> 902 ;;<DateTime> 903 ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime> 904 ;;</DateTime> 905 ;;<Description> 906 ;;<Text> 907 ;;</Text> 908 ;;</Description> 909 ;;<Source> 910 ;;<Actor> 911 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 912 ;;</Actor> 913 ;;</Source> 914 ;;</Comment> 915 ;;</Comments> 916 ;;</ContinuityOfCareRecord> 917 ;</TEMPLATE> -
ccr/trunk/p/C0CCMT.m
r785 r1204 1 C0CCMT 2 ;;1.0;C0C;;May 21, 2010; 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.0;C0C;;May 21, 2010;Build 38 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/trunk/p/C0CCPT.m
r780 r1204 1 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;Sequence Managers Software GPL 2 ;Sequence Managers Software GPL;;;;;Build 38 3 3 ;Copied into C0C namespace from SQMCPT with permission from 4 4 ;Brian Lord - and with our thanks. gpl 01/20/2010 … … 9 9 ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE 10 10 ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 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 S Z="" 22 F S Z=$O(NOTE(Z)) Q:Z="" D 23 . S DT=$P(^TIU(8925,Z,0),U,7) 24 . I $G(STDT)]"" D 25 .. I STDT>DT S NOTE(Z)="D" ;SET NOTE TO BE DELETED 26 . I $G(ENDDT)]"" D 27 .. I ENDDT<DT S NOTE(Z)="D" 28 . I NOTE(Z)="D" K NOTE(Z) 29 29 D VISIT 30 31 VISIT 30 Q 31 VISIT ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT 32 32 S ILST=1,X0="",X12="",VISIT="",LST="",X811="" 33 33 S IEN="" F S IEN=$O(NOTE(IEN)) Q:IEN="" D -
ccr/trunk/p/C0CDOM.m
r1203 r1204 126 126 Q 127 127 ; 128 OUTXML(ZRTN,INID ) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM128 OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 129 129 ; 130 130 S C0CDOCID=INID 131 D START^C0CMXMLB($$TAG(1),,"G") 131 I '$D(NO1ST) S NO1ST=0 ; DO NOT SURPRESS THE <?xml tag generation 132 D START^C0CMXMLB($$TAG(1),,"G",NO1ST) 132 133 D NDOUT($$FIRST(1)) 133 134 D END^C0CMXMLB ;END THE DOCUMENT … … 156 157 S GN2=$NA(@GN@(1)) 157 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) 158 167 Q 159 168 ; … … 217 226 I '$D(INARY) Q 0 ; NO ARRAY PASSED 218 227 I '$D(HANDLE) S HANDLE=$$NEWDOM() ; MAKE A NEW DOM 228 ;I PARENT="" S PARENT="root" 219 229 I +$G(PARENT)>0 S ZPARNODE=PARENT ; WE HAVE BEEN PASSED A PARENT NODE ID 220 E I $L( PARENT)>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL230 E I $L($G(PARENT))>0 D ; TBD FIND THE PARENT IN THE DOM AND SET LEVEL 221 231 . D STARTELE^MXMLDOM(PARENT) ; INSERT THE PARENT NODE 222 232 . S ZPARNODE=1 ; 223 233 ; WE NOW HAVE A HANDLE AND A PARENT NODE AND LEVEL HAS BEEN SET 224 D MAJOR(INARY,"",0) ; PROCESS ALL THE NODES TO BE ADDED 225 I $L(PARENT)>0 D ENDELE^MXMLDOM(PARENT) ; CLOSE OUT THE PARENT NODE 226 Q 1 ; SUCCESS 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 227 239 ; 228 MAJOR(ZARY ,ZTAG,ZNUM) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES240 MAJOR(ZARY) ; RECURSIVE ROUTINE FOR INTERMEDIATE NODES 229 241 N ZI S ZI="" 242 N ZTAG 230 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 231 259 . N ZN S ZN=0 232 260 . F S ZN=$O(@ZARY@(ZI,ZN)) Q:ZN="" D ; FOR EACH MULTIPLE 233 . . N ZS S ZS="" 234 . . I $O(@ZARY@(ZI,ZN,ZS))'["." D ; END NODES HERE 235 . . . N NEWARY 236 . . . S NEWARY=$NA(@ZARY@(ZI,ZN)) 237 . . . D MINOR("NEWARY") ; INSERT THE END NODES 238 . . E F S ZS=$O(@ZARY@(ZI,ZN,ZS)) Q:ZS="" D ; FOR EACH STRING 239 . . . I ZS["." D ; INTERMEDIATE NODE FOUND 240 . . . . W !,"IM:",ZS 241 . . . W !,ZI,":",ZN,":",ZS_" : ",@ZARY@(ZI,ZN,ZS) 242 Q 243 ; 244 MINOR(ZINARY) ; DOES THE WORK FOR END NODES, HANDLES ATTRIBUTES 245 ; 246 N ZZI S ZZI="" 247 F S ZZI=$O(@ZINARY@(ZZI)) Q:ZZI="" D ; 248 . W !,"MINOR",ZZI,":",@ZINARY@(ZZI) 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 249 265 Q 250 266 ; … … 268 284 . . . N ZZV ; PLACE TO STASH THE VALUE 269 285 . . . S ZZV=@ZZIN@(ZZI,ZZN,ZZS) ; VALUE 286 . . . W !,"VALUE:",ZZV 270 287 . . . N GK ; COUNTER 271 288 . . . F GK=1:1:$L(ZZS,".") D ; FOR EACH INTERMEDIATE NODE … … 292 309 Q 293 310 ; 294 POP(OSTR,ISTR) ; EXTRINSIC WHICH RETURNS TRUE IF ISTR IS EMPTY295 ; IF ISTR IS NOT EMPTY, LOOKS FOR "." AND "@" AND RETURNS296 ; xxx,1,yyyetc for xxx.yyyetc and xx@,1,yyy for xxx@yyyetc297 ; OSTR IS PASSED BY REFERENCE AND CONTAINS yyyetc298 I $L(ISTR)=0 Q 1 ; WE ARE DONE299 N ZG,ZN,ZR300 S ZN=1301 I ISTR["." D ;302 . S ZG=$P(ISTR,".",1)303 . S OSTR=$P(ISTR,".",2)304 . S ZR=ZG_","_ZN_","_OSTR305 Q ZR306 ;307 311 NEWDOM() ; extrinsic which creates a new DOM and returns the HANDLE 308 312 N CBK,SUCCESS,LEVEL,NODE,HANDLE … … 314 318 Q HANDLE 315 319 ; 316 317 -
ccr/trunk/p/C0CDPT.m
r767 r1204 1 1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 89 FAMILY(DFN) ; Family Name 90 91 92 90 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 91 D NAMECOMP^XLFNAME(.NAME) 92 Q NAME("FAMILY") 93 93 GIVEN(DFN) ; Given Name 94 95 96 94 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 95 D NAMECOMP^XLFNAME(.NAME) 96 Q NAME("GIVEN") 97 97 MIDDLE(DFN) ; Middle Name 98 99 100 98 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 99 D NAMECOMP^XLFNAME(.NAME) 100 Q NAME("MIDDLE") 101 101 SUFFIX(DFN) ; Suffi Name 102 103 104 102 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 103 D NAMECOMP^XLFNAME(.NAME) 104 Q NAME("SUFFIX") 105 105 DISPNAME(DFN) ; Display Name 106 107 108 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 109 DOB(DFN) ; Date of Birth 110 111 112 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 113 GENDER(DFN) ; Gender/Sex 114 114 Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; 115 115 SSN(DFN) ; SSN 116 116 Q $$GET1^DIQ(2,DFN,.09) 117 117 ADDRTYPE(DFN) ; Address Type 118 119 118 ; Vista only stores a home address for the patient. 119 Q "Home" 120 120 ADDR1(DFN) ; Get Home Address line 1 121 121 Q $$GET1^DIQ(2,DFN,.111) 122 122 ADDR2(DFN) ; Get Home Address line 2 123 124 125 126 127 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 128 CITY(DFN) ; Get City for Home Address 129 129 Q $$GET1^DIQ(2,DFN,.114) 130 130 STATE(DFN) ; Get State for Home Address 131 131 Q $$GET1^DIQ(2,DFN,.115) 132 132 ZIP(DFN) ; Get Zip code for Home Address 133 133 Q $$GET1^DIQ(2,DFN,.116) 134 134 COUNTY(DFN) ; Get County for our Address 135 135 Q $$GET1^DIQ(2,DFN,.117) 136 136 COUNTRY(DFN) ; Get Country for our Address 137 138 137 ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... 138 Q "USA" 139 139 RESTEL(DFN) ; Residential Telephone 140 140 Q $$GET1^DIQ(2,DFN,.131) 141 141 WORKTEL(DFN) ; Work Telephone 142 142 Q $$GET1^DIQ(2,DFN,.132) 143 143 EMAIL(DFN) ; Email Adddress 144 144 Q $$GET1^DIQ(2,DFN,.133) 145 145 CELLTEL(DFN) ; Cell Phone 146 146 Q $$GET1^DIQ(2,DFN,.134) 147 147 NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name 148 149 150 148 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 149 D NAMECOMP^XLFNAME(.NAME) 150 Q NAME("FAMILY") 151 151 NOK1GIV(DFN) ; NOK1 Given Name 152 153 154 152 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 153 D NAMECOMP^XLFNAME(.NAME) 154 Q NAME("GIVEN") 155 155 NOK1MID(DFN) ; NOK1 Middle Name 156 157 158 156 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 157 D NAMECOMP^XLFNAME(.NAME) 158 Q NAME("MIDDLE") 159 159 NOK1SUF(DFN) ; NOK1 Suffi Name 160 161 162 160 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 161 D NAMECOMP^XLFNAME(.NAME) 162 Q NAME("SUFFIX") 163 163 NOK1DISP(DFN) ; NOK1 Display Name 164 165 166 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 167 NOK1REL(DFN) ; NOK1 Relationship to the patient 168 168 Q $$GET1^DIQ(2,DFN,.212) 169 169 NOK1ADD1(DFN) ; NOK1 Address 1 170 170 Q $$GET1^DIQ(2,DFN,.213) 171 171 NOK1ADD2(DFN) ; NOK1 Address 2 172 173 174 175 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 176 NOK1CITY(DFN) ; NOK1 City 177 177 Q $$GET1^DIQ(2,DFN,.216) 178 178 NOK1STAT(DFN) ; NOK1 State 179 179 Q $$GET1^DIQ(2,DFN,.217) 180 180 NOK1ZIP(DFN) ; NOK1 Zip Code 181 181 Q $$GET1^DIQ(2,DFN,.218) 182 182 NOK1HTEL(DFN) ; NOK1 Home Telephone 183 183 Q $$GET1^DIQ(2,DFN,.219) 184 184 NOK1WTEL(DFN) ; NOK1 Work Telephone 185 185 Q $$GET1^DIQ(2,DFN,.21011) 186 186 NOK1SAME(DFN) ; Is NOK1's Address the same the patient? 187 187 Q $$GET1^DIQ(2,DFN,.2125) 188 188 NOK2FAM(DFN) ; NOK2 Family Name 189 190 191 189 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 190 D NAMECOMP^XLFNAME(.NAME) 191 Q NAME("FAMILY") 192 192 NOK2GIV(DFN) ; NOK2 Given Name 193 194 195 193 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 194 D NAMECOMP^XLFNAME(.NAME) 195 Q NAME("GIVEN") 196 196 NOK2MID(DFN) ; NOK2 Middle Name 197 198 199 197 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 198 D NAMECOMP^XLFNAME(.NAME) 199 Q NAME("MIDDLE") 200 200 NOK2SUF(DFN) ; NOK2 Suffi Name 201 202 203 201 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 202 D NAMECOMP^XLFNAME(.NAME) 203 Q NAME("SUFFIX") 204 204 NOK2DISP(DFN) ; NOK2 Display Name 205 206 207 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 208 NOK2REL(DFN) ; NOK2 Relationship to the patient 209 209 Q $$GET1^DIQ(2,DFN,.2192) 210 210 NOK2ADD1(DFN) ; NOK2 Address 1 211 211 Q $$GET1^DIQ(2,DFN,.2193) 212 212 NOK2ADD2(DFN) ; NOK2 Address 2 213 214 215 216 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 217 NOK2CITY(DFN) ; NOK2 City 218 218 Q $$GET1^DIQ(2,DFN,.2196) 219 219 NOK2STAT(DFN) ; NOK2 State 220 220 Q $$GET1^DIQ(2,DFN,.2197) 221 221 NOK2ZIP(DFN) ; NOK2 Zip Code 222 222 Q $$GET1^DIQ(2,DFN,.2198) 223 223 NOK2HTEL(DFN) ; NOK2 Home Telephone 224 224 Q $$GET1^DIQ(2,DFN,.2199) 225 225 NOK2WTEL(DFN) ; NOK2 Work Telephone 226 226 Q $$GET1^DIQ(2,DFN,.211011) 227 227 NOK2SAME(DFN) ; Is NOK2's Address the same the patient? 228 228 Q $$GET1^DIQ(2,DFN,.21925) 229 229 EMERFAM(DFN) ; Emergency Contact (EMER) Family Name 230 231 232 230 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 231 D NAMECOMP^XLFNAME(.NAME) 232 Q NAME("FAMILY") 233 233 EMERGIV(DFN) ; EMER Given Name 234 235 236 234 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 235 D NAMECOMP^XLFNAME(.NAME) 236 Q NAME("GIVEN") 237 237 EMERMID(DFN) ; EMER Middle Name 238 239 240 238 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 239 D NAMECOMP^XLFNAME(.NAME) 240 Q NAME("MIDDLE") 241 241 EMERSUF(DFN) ; EMER Suffi Name 242 243 244 242 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 243 D NAMECOMP^XLFNAME(.NAME) 244 Q NAME("SUFFIX") 245 245 EMERDISP(DFN) ; EMER Display Name 246 247 248 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 249 EMERREL(DFN) ; EMER Relationship to the patient 250 250 Q $$GET1^DIQ(2,DFN,.331) 251 251 EMERADD1(DFN) ; EMER Address 1 252 252 Q $$GET1^DIQ(2,DFN,.333) 253 253 EMERADD2(DFN) ; EMER Address 2 254 255 256 257 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 258 EMERCITY(DFN) ; EMER City 259 259 Q $$GET1^DIQ(2,DFN,.336) 260 260 EMERSTAT(DFN) ; EMER State 261 261 Q $$GET1^DIQ(2,DFN,.337) 262 262 EMERZIP(DFN) ; EMER Zip Code 263 263 Q $$GET1^DIQ(2,DFN,.338) 264 264 EMERHTEL(DFN) ; EMER Home Telephone 265 265 Q $$GET1^DIQ(2,DFN,.339) 266 266 EMERWTEL(DFN) ; EMER Work Telephone 267 267 Q $$GET1^DIQ(2,DFN,.33011) 268 268 EMERSAME(DFN) ; Is EMER's Address the same the NOK? 269 269 Q $$GET1^DIQ(2,DFN,.3305) -
ccr/trunk/p/C0CENC.m
r786 r1204 1 C0CENC 2 ;;1.0;C0C;;May 21, 2010; 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.0;C0C;;May 21, 2010;Build 38 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/trunk/p/C0CEWD.m
r1060 r1204 1 C0CEWD 2 ;;0.1;CCDCCR;nopatch;noreleasedate 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 ;;0.1;CCDCCR;nopatch;noreleasedate;Build 77 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/trunk/p/C0CFM1.m
r508 r1204 1 1 C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 25 26 27 28 29 30 31 32 33 34 35 36 37 38 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 39 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 40 41 42 43 44 45 46 47 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 48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 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 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 95 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 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 117 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 118 119 120 121 122 123 124 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 125 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 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 142 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 143 144 145 146 147 148 149 150 151 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 152 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 153 154 155 156 157 158 159 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 160 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 161 162 163 164 165 166 167 168 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 169 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 170 171 172 173 174 175 176 177 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/trunk/p/C0CFM2.m
r572 r1204 1 1 C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 30 RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE 31 32 33 34 35 36 37 38 39 40 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 41 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 42 43 44 45 46 47 48 49 50 51 52 53 54 55 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 56 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 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 80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 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 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 147 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 148 149 150 151 152 153 154 155 156 157 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 158 CHECK ; CHECKSUM EXPERIMENTS 159 160 161 162 163 164 165 166 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 167 CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 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 188 DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) 189 190 191 192 189 D SETXUP 190 D CHKELS(DFN) 191 Q 192 ; 193 193 SETXUP ; SET UP ENVIRONMENT 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 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 226 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 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 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 280 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 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 302 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 303 304 305 306 307 308 309 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 310 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 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 327 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 328 329 330 331 332 333 334 335 336 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 337 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 338 339 340 341 342 343 344 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 345 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 346 347 348 349 350 351 352 353 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 354 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 355 356 357 358 359 360 361 362 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/trunk/p/C0CIM2.m
r706 r1204 1 C0CIM2 2 ;;1.0;C0C;;Feb 16, 2010; 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.0;C0C;;Feb 16, 2010;Build 38 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/trunk/p/C0CIMMU.m
r508 r1204 1 1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 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 49 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES 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 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/trunk/p/C0CIN.m
r752 r1204 1 1 C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 2 ;;1.0;C0C;;Sep 20, 2009; 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 2 ;;1.0;C0C;;Sep 20, 2009;Build 38 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 183 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 184 185 186 187 188 189 190 191 192 193 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/trunk/p/C0CLA7Q.m
r533 r1204 1 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 2 ;;1.0;C0C;;May 19, 2009; 2 ;;1.0;C0C;;May 19, 2009;Build 38 3 3 ; 4 4 ; -
ccr/trunk/p/C0CLABS.m
r600 r1204 1 C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 2 ;;1.0;C0C;;May 19, 2009; 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 S C0CQT=QTSAV ; RESET SILENT FLAG 133 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT 134 I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS 135 Q 136 ; 137 GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT 138 ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR 139 ; SET UP FOR LAB API CALL 140 S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT 141 I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT 142 . W "LAB LOOKUP FAILED, NO SSN",! 143 . S C0CNSSN=1 ; SET NO SSN FLAG 144 S C0CSPC="*" ; LOOKING FOR ALL LABS 145 ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS 146 ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME 147 ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING 148 ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY 149 S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM 150 S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM 151 D DT^DILF(,C0CLLMT,.C0CSDT) ; 152 W "LAB LIMIT: ",C0CLLMT,! 153 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM 154 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP 155 Q 156 ; 157 LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB 158 ; 159 ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR 160 I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS 161 I '$D(C0CQT) S C0CQT=0 162 I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT 163 I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE 164 I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION 165 I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE 166 S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE 167 S C0CHB=$NA(^TMP("HLS",$J)) 168 S C0CI="" 169 S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT 170 F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG 171 . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES 172 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) 173 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) 174 . M XV=C0CVAR ; 175 . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION 176 . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT 177 . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT 178 . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS 179 . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI 180 . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR 181 . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) 182 . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT 183 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 184 . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 185 . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS 186 . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION 187 . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 188 . . ; RESULTTESTCODEVALUE 189 . . ; RESULTTESTDESCRIPTIONTEXT 190 . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC 191 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE 192 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 193 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESCRIPTION TEXT 194 . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC 195 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE 196 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 197 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT 198 . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT 199 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE 200 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME 201 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT 202 . . E D ; NO SECONDARY, USE PRIMARY 203 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE 204 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME 205 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT 206 . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; 207 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 208 . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 209 . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG 210 . . S C0CZG=XV("RESULTTESTVALUE") 211 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 212 . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 213 . . S XV("RESULTTESTVALUE")=C0CZG 214 . I C0CTYP="OBX" D ; PROCESS TEST RESULTS 215 . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION 216 . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS 217 . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT 218 . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT 219 . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX 220 . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE 221 . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER 222 . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 223 . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") 224 . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT 225 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 226 . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 227 . . ; I 'C0CQT ZWR XV 228 . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES 229 . I 'C0CQT D ; 230 . . W C0CI," ",C0CTYP,! 231 . ; S C0CI=$O(@C0CHB@(C0CI)) 232 ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") 233 ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB 234 Q 235 LTYP(OSEG,OTYP,OVARA,OC0CQT) ; 236 S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE 237 I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT 238 E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG 239 I 1 D ; FOR HL7 SEGMENT TYPE 240 . S OI="" ; INDEX INTO FIELDS IN SEG 241 . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT 242 . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX 243 . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED 244 . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE 245 . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE 246 . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX 247 . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE 248 . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE 249 . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE 250 . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! 251 Q 252 LOBX ; 253 Q 254 ; 255 OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) 256 N GA,GF,GD 257 S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) 258 S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" 259 S GD=^TMP("C0CCCR","ODIR") 260 W $$OUTPUT^C0CXPATH(GA,GF,GD) 261 Q 262 ; 263 SETTBL ; 264 K X ; CLEAR X 265 S X("PID","PID1")="1^00104^Set ID - Patient ID" 266 S X("PID","PID2")="2^00105^Patient ID (External ID)" 267 S X("PID","PID3")="3^00106^Patient ID (Internal ID)" 268 S X("PID","PID4")="4^00107^Alternate Patient ID" 269 S X("PID","PID5")="5^00108^Patient's Name" 270 S X("PID","PID6")="6^00109^Mother's Maiden Name" 271 S X("PID","PID7")="7^00110^Date of Birth" 272 S X("PID","PID8")="8^00111^Sex" 273 S X("PID","PID9")="9^00112^Patient Alias" 274 S X("PID","PID10")="10^00113^Race" 275 S X("PID","PID11")="11^00114^Patient Address" 276 S X("PID","PID12")="12^00115^County Code" 277 S X("PID","PID13")="13^00116^Phone Number - Home" 278 S X("PID","PID14")="14^00117^Phone Number - Business" 279 S X("PID","PID15")="15^00118^Language - Patient" 280 S X("PID","PID16")="16^00119^Marital Status" 281 S X("PID","PID17")="17^00120^Religion" 282 S X("PID","PID18")="18^00121^Patient Account Number" 283 S X("PID","PID19")="19^00122^SSN Number - Patient" 284 S X("PID","PID20")="20^00123^Drivers License - Patient" 285 S X("PID","PID21")="21^00124^Mother's Identifier" 286 S X("PID","PID22")="22^00125^Ethnic Group" 287 S X("PID","PID23")="23^00126^Birth Place" 288 S X("PID","PID24")="24^00127^Multiple Birth Indicator" 289 S X("PID","PID25")="25^00128^Birth Order" 290 S X("PID","PID26")="26^00129^Citizenship" 291 S X("PID","PID27")="27^00130^Veteran.s Military Status" 292 S X("PID","PID28")="28^00739^Nationality" 293 S X("PID","PID29")="29^00740^Patient Death Date/Time" 294 S X("PID","PID30")="30^00741^Patient Death Indicator" 295 S X("NTE","NTE1")="1^00573^Set ID - NTE" 296 S X("NTE","NTE2")="2^00574^Source of Comment" 297 S X("NTE","NTE3")="3^00575^Comment" 298 S X("ORC","ORC1")="1^00215^Order Control" 299 S X("ORC","ORC2")="2^00216^Placer Order Number" 300 S X("ORC","ORC3")="3^00217^Filler Order Number" 301 S X("ORC","ORC4")="4^00218^Placer Order Number" 302 S X("ORC","ORC5")="5^00219^Order Status" 303 S X("ORC","ORC6")="6^00220^Response Flag" 304 S X("ORC","ORC7")="7^00221^Quantity/Timing" 305 S X("ORC","ORC8")="8^00222^Parent" 306 S X("ORC","ORC9")="9^00223^Date/Time of Transaction" 307 S X("ORC","ORC10")="10^00224^Entered By" 308 S X("ORC","ORC11")="11^00225^Verified By" 309 S X("ORC","ORC12")="12^00226^Ordering Provider" 310 S X("ORC","ORC13")="13^00227^Enterer's Location" 311 S X("ORC","ORC14")="14^00228^Call Back Phone Number" 312 S X("ORC","ORC15")="15^00229^Order Effective Date/Time" 313 S X("ORC","ORC16")="16^00230^Order Control Code Reason" 314 S X("ORC","ORC17")="17^00231^Entering Organization" 315 S X("ORC","ORC18")="18^00232^Entering Device" 316 S X("ORC","ORC19")="19^00233^Action By" 317 S X("OBR","OBR1")="1^00237^Set ID - Observation Request" 318 S X("OBR","OBR2")="2^00216^Placer Order Number" 319 S X("OBR","OBR3")="3^00217^Filler Order Number" 320 S X("OBR","OBR4")="4^00238^Universal Service ID" 321 S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" 322 S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" 323 S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" 324 S X("OBR","OBR5")="5^00239^Priority" 325 S X("OBR","OBR6")="6^00240^Requested Date/Time" 326 S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" 327 S X("OBR","OBR8")="8^00242^Observation End Date/Time" 328 S X("OBR","OBR9")="9^00243^Collection Volume" 329 S X("OBR","OBR10")="10^00244^Collector Identifier" 330 S X("OBR","OBR11")="11^00245^Specimen Action Code" 331 S X("OBR","OBR12")="12^00246^Danger Code" 332 S X("OBR","OBR13")="13^00247^Relevant Clinical Info." 333 S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" 334 S X("OBR","OBR15")="15^00249^Specimen Source" 335 S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" 336 S X("OBR","OBR17")="17^00250^Order Callback Phone Number" 337 S X("OBR","OBR18")="18^00251^Placers Field 1" 338 S X("OBR","OBR19")="19^00252^Placers Field 2" 339 S X("OBR","OBR20")="20^00253^Filler Field 1" 340 S X("OBR","OBR21")="21^00254^Filler Field 2" 341 S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" 342 S X("OBR","OBR23")="23^00256^Charge to Practice" 343 S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" 344 S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" 345 S X("OBR","OBR26")="26^00259^Parent Result" 346 S X("OBR","OBR27")="27^00221^Quantity/Timing" 347 S X("OBR","OBR28")="28^00260^Result Copies to" 348 S X("OBR","OBR29")="29^00261^Parent Number" 349 S X("OBR","OBR30")="30^00262^Transportation Mode" 350 S X("OBR","OBR31")="31^00263^Reason for Study" 351 S X("OBR","OBR32")="32^00264^Principal Result Interpreter" 352 S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" 353 S X("OBR","OBR34")="34^00266^Technician" 354 S X("OBR","OBR35")="35^00267^Transcriptionist" 355 S X("OBR","OBR36")="36^00268^Scheduled Date/Time" 356 S X("OBR","OBR37")="37^01028^Number of Sample Containers" 357 S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" 358 S X("OBR","OBR39")="39^01030^Collector.s Comment" 359 S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" 360 S X("OBR","OBR41")="41^01032^Transport Arranged" 361 S X("OBR","OBR42")="42^01033^Escort Required" 362 S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" 363 S X("OBX","OBX1")="1^00559^Set ID - OBX" 364 S X("OBX","OBX2")="2^00676^Value Type" 365 S X("OBX","OBX3")="3^00560^Observation Identifier" 366 S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" 367 S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" 368 S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" 369 S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" 370 S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" 371 S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" 372 S X("OBX","OBX4")="4^00769^Observation Sub-Id" 373 S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" 374 S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" 375 S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" 376 S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" 377 S X("OBX","OBX9")="9^00639^Probability" 378 S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" 379 S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" 380 S X("OBX","OBX12")="12^00567^Date Last Normal Value" 381 S X("OBX","OBX13")="13^00581^User Defined Access Checks" 382 S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" 383 S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" 384 S X("OBX","OBX16")="16^00584^Responsible Observer" 385 S X("OBX","OBX17")="17^00936^Observation Method" 386 K ^TMP("C0CCCR","LABTBL") 387 M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL 388 S ^TMP("C0CCCR","LABTBL",0)="V3" 389 Q 390 ; 1 C0CALABS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR LAB RESULTS ; 10/01/08 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 S C0CQT=QTSAV ; RESET SILENT FLAG 133 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT 134 I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS 135 Q 136 ; 137 GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT 138 ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR 139 ; SET UP FOR LAB API CALL 140 S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT 141 I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT 142 . W "LAB LOOKUP FAILED, NO SSN",! 143 . S C0CNSSN=1 ; SET NO SSN FLAG 144 S C0CSPC="*" ; LOOKING FOR ALL LABS 145 ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS 146 ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME 147 ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING 148 ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY 149 S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM 150 S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM 151 D DT^DILF(,C0CLLMT,.C0CSDT) ; 152 W "LAB LIMIT: ",C0CLLMT,! 153 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM 154 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP 155 Q 156 ; 157 LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB 158 ; 159 ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR 160 I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS 161 I '$D(C0CQT) S C0CQT=0 162 I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT 163 I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE 164 I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION 165 I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE 166 S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE 167 S C0CHB=$NA(^TMP("HLS",$J)) 168 S C0CI="" 169 S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT 170 F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG 171 . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES 172 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) 173 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) 174 . M XV=C0CVAR ; 175 . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION 176 . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT 177 . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT 178 . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS 179 . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI 180 . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR 181 . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) 182 . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT 183 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 184 . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 185 . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS 186 . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION 187 . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 188 . . ; RESULTTESTCODEVALUE 189 . . ; RESULTTESTDESCRIPTIONTEXT 190 . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC 191 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE 192 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 193 . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT 194 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") 195 . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC 196 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE 197 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 198 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT 199 . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT 200 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE 201 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME 202 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT 203 . . E D ; NO SECONDARY, USE PRIMARY 204 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE 205 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME 206 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT 207 . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; 208 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 209 . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 210 . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG 211 . . S C0CZG=XV("RESULTTESTVALUE") 212 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 213 . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 214 . . S XV("RESULTTESTVALUE")=C0CZG 215 . I C0CTYP="OBX" D ; PROCESS TEST RESULTS 216 . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION 217 . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS 218 . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT 219 . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT 220 . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX 221 . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE 222 . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER 223 . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 224 . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") 225 . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT 226 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 227 . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 228 . . ; I 'C0CQT ZWR XV 229 . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES 230 . I 'C0CQT D ; 231 . . W C0CI," ",C0CTYP,! 232 . ; S C0CI=$O(@C0CHB@(C0CI)) 233 ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") 234 ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB 235 Q 236 LTYP(OSEG,OTYP,OVARA,OC0CQT) ; 237 S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE 238 I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT 239 E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG 240 I 1 D ; FOR HL7 SEGMENT TYPE 241 . S OI="" ; INDEX INTO FIELDS IN SEG 242 . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT 243 . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX 244 . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED 245 . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE 246 . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE 247 . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX 248 . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE 249 . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE 250 . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE 251 . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! 252 Q 253 LOBX ; 254 Q 255 ; 256 OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) 257 N GA,GF,GD 258 S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) 259 S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" 260 S GD=^TMP("C0CCCR","ODIR") 261 W $$OUTPUT^C0CXPATH(GA,GF,GD) 262 Q 263 ; 264 SETTBL ; 265 K X ; CLEAR X 266 S X("PID","PID1")="1^00104^Set ID - Patient ID" 267 S X("PID","PID2")="2^00105^Patient ID (External ID)" 268 S X("PID","PID3")="3^00106^Patient ID (Internal ID)" 269 S X("PID","PID4")="4^00107^Alternate Patient ID" 270 S X("PID","PID5")="5^00108^Patient's Name" 271 S X("PID","PID6")="6^00109^Mother's Maiden Name" 272 S X("PID","PID7")="7^00110^Date of Birth" 273 S X("PID","PID8")="8^00111^Sex" 274 S X("PID","PID9")="9^00112^Patient Alias" 275 S X("PID","PID10")="10^00113^Race" 276 S X("PID","PID11")="11^00114^Patient Address" 277 S X("PID","PID12")="12^00115^County Code" 278 S X("PID","PID13")="13^00116^Phone Number - Home" 279 S X("PID","PID14")="14^00117^Phone Number - Business" 280 S X("PID","PID15")="15^00118^Language - Patient" 281 S X("PID","PID16")="16^00119^Marital Status" 282 S X("PID","PID17")="17^00120^Religion" 283 S X("PID","PID18")="18^00121^Patient Account Number" 284 S X("PID","PID19")="19^00122^SSN Number - Patient" 285 S X("PID","PID20")="20^00123^Drivers License - Patient" 286 S X("PID","PID21")="21^00124^Mother's Identifier" 287 S X("PID","PID22")="22^00125^Ethnic Group" 288 S X("PID","PID23")="23^00126^Birth Place" 289 S X("PID","PID24")="24^00127^Multiple Birth Indicator" 290 S X("PID","PID25")="25^00128^Birth Order" 291 S X("PID","PID26")="26^00129^Citizenship" 292 S X("PID","PID27")="27^00130^Veteran.s Military Status" 293 S X("PID","PID28")="28^00739^Nationality" 294 S X("PID","PID29")="29^00740^Patient Death Date/Time" 295 S X("PID","PID30")="30^00741^Patient Death Indicator" 296 S X("NTE","NTE1")="1^00573^Set ID - NTE" 297 S X("NTE","NTE2")="2^00574^Source of Comment" 298 S X("NTE","NTE3")="3^00575^Comment" 299 S X("ORC","ORC1")="1^00215^Order Control" 300 S X("ORC","ORC2")="2^00216^Placer Order Number" 301 S X("ORC","ORC3")="3^00217^Filler Order Number" 302 S X("ORC","ORC4")="4^00218^Placer Order Number" 303 S X("ORC","ORC5")="5^00219^Order Status" 304 S X("ORC","ORC6")="6^00220^Response Flag" 305 S X("ORC","ORC7")="7^00221^Quantity/Timing" 306 S X("ORC","ORC8")="8^00222^Parent" 307 S X("ORC","ORC9")="9^00223^Date/Time of Transaction" 308 S X("ORC","ORC10")="10^00224^Entered By" 309 S X("ORC","ORC11")="11^00225^Verified By" 310 S X("ORC","ORC12")="12^00226^Ordering Provider" 311 S X("ORC","ORC13")="13^00227^Enterer's Location" 312 S X("ORC","ORC14")="14^00228^Call Back Phone Number" 313 S X("ORC","ORC15")="15^00229^Order Effective Date/Time" 314 S X("ORC","ORC16")="16^00230^Order Control Code Reason" 315 S X("ORC","ORC17")="17^00231^Entering Organization" 316 S X("ORC","ORC18")="18^00232^Entering Device" 317 S X("ORC","ORC19")="19^00233^Action By" 318 S X("OBR","OBR1")="1^00237^Set ID - Observation Request" 319 S X("OBR","OBR2")="2^00216^Placer Order Number" 320 S X("OBR","OBR3")="3^00217^Filler Order Number" 321 S X("OBR","OBR4")="4^00238^Universal Service ID" 322 S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" 323 S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" 324 S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" 325 S X("OBR","OBR5")="5^00239^Priority" 326 S X("OBR","OBR6")="6^00240^Requested Date/Time" 327 S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" 328 S X("OBR","OBR8")="8^00242^Observation End Date/Time" 329 S X("OBR","OBR9")="9^00243^Collection Volume" 330 S X("OBR","OBR10")="10^00244^Collector Identifier" 331 S X("OBR","OBR11")="11^00245^Specimen Action Code" 332 S X("OBR","OBR12")="12^00246^Danger Code" 333 S X("OBR","OBR13")="13^00247^Relevant Clinical Info." 334 S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" 335 S X("OBR","OBR15")="15^00249^Specimen Source" 336 S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" 337 S X("OBR","OBR17")="17^00250^Order Callback Phone Number" 338 S X("OBR","OBR18")="18^00251^Placers Field 1" 339 S X("OBR","OBR19")="19^00252^Placers Field 2" 340 S X("OBR","OBR20")="20^00253^Filler Field 1" 341 S X("OBR","OBR21")="21^00254^Filler Field 2" 342 S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" 343 S X("OBR","OBR23")="23^00256^Charge to Practice" 344 S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" 345 S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" 346 S X("OBR","OBR26")="26^00259^Parent Result" 347 S X("OBR","OBR27")="27^00221^Quantity/Timing" 348 S X("OBR","OBR28")="28^00260^Result Copies to" 349 S X("OBR","OBR29")="29^00261^Parent Number" 350 S X("OBR","OBR30")="30^00262^Transportation Mode" 351 S X("OBR","OBR31")="31^00263^Reason for Study" 352 S X("OBR","OBR32")="32^00264^Principal Result Interpreter" 353 S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" 354 S X("OBR","OBR34")="34^00266^Technician" 355 S X("OBR","OBR35")="35^00267^Transcriptionist" 356 S X("OBR","OBR36")="36^00268^Scheduled Date/Time" 357 S X("OBR","OBR37")="37^01028^Number of Sample Containers" 358 S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" 359 S X("OBR","OBR39")="39^01030^Collector.s Comment" 360 S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" 361 S X("OBR","OBR41")="41^01032^Transport Arranged" 362 S X("OBR","OBR42")="42^01033^Escort Required" 363 S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" 364 S X("OBX","OBX1")="1^00559^Set ID - OBX" 365 S X("OBX","OBX2")="2^00676^Value Type" 366 S X("OBX","OBX3")="3^00560^Observation Identifier" 367 S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" 368 S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" 369 S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" 370 S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" 371 S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" 372 S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" 373 S X("OBX","OBX4")="4^00769^Observation Sub-Id" 374 S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" 375 S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" 376 S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" 377 S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" 378 S X("OBX","OBX9")="9^00639^Probability" 379 S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" 380 S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" 381 S X("OBX","OBX12")="12^00567^Date Last Normal Value" 382 S X("OBX","OBX13")="13^00581^User Defined Access Checks" 383 S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" 384 S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" 385 S X("OBX","OBX16")="16^00584^Responsible Observer" 386 S X("OBX","OBX17")="17^00936^Observation Method" 387 K ^TMP("C0CCCR","LABTBL") 388 M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL 389 S ^TMP("C0CCCR","LABTBL",0)="V3" 390 Q 391 ; -
ccr/trunk/p/C0CMED.m
r974 r1204 1 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 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 ; Inpatient UD Meds 82 D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 83 D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds 84 ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 85 D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL 86 I @HIST@(0)>0 D 87 . D CP^C0CXPATH(HIST,MEDOUTXML) 88 . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! 89 I @PEND@(0)>0 D 90 . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical 91 . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy 92 . W:$G(DEBUG) "HAS OP PENDING MEDS",! 93 I @NVA@(0)>0 D 94 . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) 95 . E D CP^C0CXPATH(NVA,MEDOUTXML) 96 . W:$G(DEBUG) "HAS NON-VA MEDS",! 97 N ZI 98 S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 99 M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES 100 K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 101 K @PEND 102 K @HIST 103 K @NVA 104 Q 105 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/trunk/p/C0CMED1.m
r508 r1204 1 1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 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 . S @MAP@("MEDLASTFILLDATE")=$$FMDTOUTC^C0CUTIL($P(MED(101),U))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 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 QUIT 59 ZWRITE:$G(DEBUG) MEDS 60 N RXIEN S RXIEN=0 61 F S RXIEN=$O(MEDS(RXIEN)) Q: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/trunk/p/C0CMED2.m
r974 r1204 1 1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 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 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/trunk/p/C0CMED3.m
r974 r1204 1 1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template 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 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 . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 117 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 118 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 119 . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 120 . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 121 . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 122 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 123 . . ; 124 . . E S (RXNORM,RXNNAME,RXNVER)="" 125 . . ; End if/else block 126 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 127 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 128 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 129 . . ; 130 . . S @MAP@("MEDBRANDNAMETEXT")="" 131 . . ; DOSE^PSS50 ONLY ESISTS ON VISTA 132 . . I '$$RPMS^C0CUTIL() D 133 . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 134 . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 135 . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 136 . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 137 . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" 138 . . ; Units, concentration, etc, come from another call 139 . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 140 . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 141 . . ; NDF Entry IEN, and VA Product Name 142 . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 143 . . ; Documented in the same manual; executed above. 144 . . ; 145 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 146 . . ; and this will crash the call. So... 147 . . I NDFIEN="" S CONCDATA="" 148 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 149 . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 150 . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 151 . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 152 . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. 153 . . ; Oddly, there is no easy place to find the dispense unit. 154 . . ; It's not included in the original call, so we have to go to the drug file. 155 . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 156 . . ; Node 14.5 is the Dispense Unit 157 . . ; PSS50 ONLY EXISTS ON VISTA 158 . . I '$$RPMS^C0CUTIL() D 159 . . . D DATA^PSS50(MEDIEN,,,,,"QTY") 160 . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 161 . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 162 . . E S @MAP@("MEDQUANTITYUNIT")="" 163 . E D 164 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" 165 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 166 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" 167 . . S @MAP@("MEDBRANDNAMETEXT")="" 168 . . S @MAP@("MEDSTRENGTHVALUE")="" 169 . . S @MAP@("MEDSTRENGTHUNIT")="" 170 . . S @MAP@("MEDFORMTEXT")="" 171 . . S @MAP@("MEDCONCVALUE")="" 172 . . S @MAP@("MEDCONCUNIT")="" 173 . . S @MAP@("MEDSIZETEXT")="" 174 . . S @MAP@("MEDQUANTITYVALUE")="" 175 . . S @MAP@("MEDQUANTITYUNIT")="" 176 . ; End If/Else 177 . ; --- START OF DIRECTIONS --- 178 . ; Dosage is field 2, route is 3, schedule is 4 179 . ; These are all free text fields, and don't point to any files 180 . ; For that reason, I will use the field I never used before: 181 . ; MEDDIRECTIONDESCRIPTIONTEXT 182 . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS 183 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 184 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 185 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" 186 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" 187 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" 188 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 189 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 190 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 191 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" 192 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" 193 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" 194 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" 195 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" 196 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" 197 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" 198 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" 199 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" 200 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" 201 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" 202 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" 203 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" 204 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" 205 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" 206 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" 207 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" 208 . ; 209 . ; --- END OF DIRECTIONS --- 210 . ; 211 . S @MAP@("MEDRFNO")="" 212 . I $D(MED(14,1)) D ; 213 . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 214 . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 215 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 216 . K @RESULT 217 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 218 . ; D PARY^C0CXPATH(RESULT) 219 . ; MAPPING DIRECTIONS 220 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 221 . N MEDDIR2,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 . ; 231 . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION 232 . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE 233 . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT 234 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) 235 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") 236 . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 237 . ;S MDI1=$NA(@MAP@("I")) 238 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 239 . I $D(MED(10,1)) D ; 240 . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 241 . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 242 . E S @MAP@("MEDPTINSTRUCTIONS")="" 243 . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" 244 . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) 245 . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL 246 . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") 247 . ; 248 . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. 249 . ;I MEDFIRST D ; 250 . ;. S MEDFIRST=0 ; RESET FIRST FLAG 251 . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 252 . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML 253 . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 254 . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 255 . I MEDFIRST S MEDFIRST=0 256 N MEDTMP,MEDI 257 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 258 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 259 . W "MEDICATION MISSING ",! 260 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 261 Q 262 ; -
ccr/trunk/p/C0CMIME.m
r1191 r1204 1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 1 C0CMIME ; CCDCCR/GPL - MIME manipulation utilities; 3/8/11 ; 5/16/11 2:32pm 2 2 ;;1.0;C0C;;Mar 8, 2011; 3 3 ;Copyright 2008 George Lilly. Licensed under the terms of the GNU … … 81 81 S C0CGM(4)="It is purely test data used for software development" 82 82 S C0CGM(5)="It does not represent information about any person living or dead" 83 S ZTO("glilly@glilly.net")="" 84 S ZTO("LILLY.GEORGE@mdc-crew.net")="" 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")="" 85 89 ;S ZTO("ncoal@live.com")="" 86 90 ;S ZTO("martijn@djigzo.com")="" 87 91 ;S ZTO("profmish@gmail.com")="" 88 92 ;S ZTO("nanthracite@earthlink.net")="" 89 S ZFROM="ANTHRACITE.NANCY" 93 S ZTO("gpl.doctortest@gmail.com")="" 94 S ZFROM="LILLY.GEORGE" 90 95 S ZATTACH=$NA(^GPL("CCR")) 91 96 I $G(@ZATTACH@(1))="" D ; NO CCR THERE … … 93 98 . M @ZATTACH=GPL ; PUT IT IN THERE FOR NEXT TIME 94 99 S ZSUBJECT="TEST OF THE NEW MAILSEND ROUTINE" 95 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH )100 D MAILSEND(.GR,ZFROM,"ZTO",,ZSUBJECT,"C0CGM",ZATTACH,"CCR.xml") 96 101 ZWR GR 97 102 Q 98 103 ; 99 MAILSEND(RTN,FROM,TO,CC,SUBJECT,MESSAGE,ATTACH,FLAGS) ; MAIL SENDING INTERFACE 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 100 126 ; RTN IS THE RETURN ARRAY PASSED BY REFERENCE 101 127 ; FROM IS PASSED BY VALUE AND IS THE EMAIL ADDRESS OF THE SENDER … … 107 133 ; MESSAGE IS PASSED BY NAME AND IS AN ARRAY OF TEXT 108 134 ; ATTACH IS PASSED BY NAME AND IS AN XML OR HTML FILE TO BE ATTACHED 109 ; 135 ; FNAME IS THE FILENAME OF THE ATTACHMENT, DEFAULT IS ccr.xml 136 ; 137 I '$D(FNAME) S FNAME="ccr.xml" ; default filename 110 138 N GN 111 139 S GN=$NA(^TMP($J,"C0CMIME")) … … 113 141 S GM(1)="MIME-Version: 1.0" 114 142 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 115 S GM(3)=" 116 S GM(4)=" 143 S GM(3)="" 144 S GM(4)="" 117 145 ;S GM(5)="--123456788888" 118 146 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) 119 147 S GM(5)="--123456899999" 120 S GM(6)="Content-Type: text/xml; name=" "ccr.xml"""148 S GM(6)="Content-Type: text/xml; name="_FNAME 121 149 S GM(7)="Content-Transfer-Encoding: base64" 122 S GM(8)="Content-Disposition: attachment; filename=" "ccr.xml"""123 S GM(9)=" 124 S GM(10)=" 150 S GM(8)="Content-Disposition: attachment; filename="_FNAME 151 S GM(9)="" 152 S GM(10)="" ; FOR THE END 125 153 ;S GM(11)="--123456788888--" 126 154 S GM(11)="--123456899999--" 127 S GM(12)=" 128 S GM(13)=" 155 S GM(12)="" 156 S GM(13)="" 129 157 S GG(1)="--123456899999" 130 158 S GG(2)="Content-Type: text/plain; charset=ISO-8859-1; format=flowed" 131 159 S GG(3)="Content-Transfer-Encoding: 7bit" 132 S GG(4)=" 160 S GG(4)="" 133 161 S GG(5)="This is a test message." 134 162 S GG(6)="A Continuity of Care record is attached" … … 136 164 S GG(8)="It is purely test data used for software development" 137 165 S GG(9)="It does not represent information about any person living or dead" 138 S GG(10)=" 166 S GG(10)="" 139 167 S GG(11)="--123456899999--" 140 168 ;S GG(11)="Content-Type: text/plain; charset=""us-ascii""" 141 S GG(12)=" 169 S GG(12)="" 142 170 ;S GG(13)="This is a test message." 143 171 S GG(14)="A Continuity of Care record is attached" … … 145 173 S GG(16)="It is purely test data used for software development" 146 174 S GG(17)="It does not represent information about any person living or dead" 147 S GG(18)=" 175 S GG(18)="" 148 176 S GG(19)="--123456899999" 149 177 S GG(20)="--987654321--" … … 183 211 S GM(1)="MIME-Version: 1.0" 184 212 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 185 S GM(3)=" 186 S GM(4)=" 213 S GM(3)="" 214 S GM(4)="" 187 215 S GM(5)="--1234567" 188 216 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) … … 191 219 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" 192 220 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") 193 S GM(9)=" 194 S GM(10)=" 221 S GM(9)="" 222 S GM(10)="" ; FOR THE END 195 223 S GM(11)="--frontier--" 196 224 S GM(12)="." 197 S GM(13)=" 225 S GM(13)="" 198 226 K GBLD 199 227 ;D QUEUE^C0CXPATH("GBLD","GM",1,9) … … 232 260 S GM(1)="MIME-Version: 1.0" 233 261 S GM(2)="Content-Type: multipart/mixed; boudary=""1234567""" 234 S GM(3)=" 235 S GM(4)=" 262 S GM(3)="" 263 S GM(4)="" 236 264 S GM(5)="--1234567" 237 265 ;S GM(5)=$$REPEAT^XLFSTR("-",$L(X)) … … 240 268 S GM(8)="Content-Disposition: attachment; filename=""ccr.xml""" 241 269 ;S GM(6)=$$UUBEGFN^LRSRVR2A("CCR.xml") 242 S GM(9)=" 243 S GM(10)=" 270 S GM(9)="" 271 S GM(10)="" ; FOR THE END 244 272 S GM(11)="--1234567--" 245 S GM(12)=" 246 S GM(13)=" 273 S GM(12)="" 274 S GM(13)="" 247 275 K GBLD 248 276 D QUEUE^C0CXPATH("GBLD","GM",5,9) -
ccr/trunk/p/C0CMXML.m
r1184 r1204 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate 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 ; TEST DRIVER ASSUMES A CCR IN ^GPL("CCR") 27 ; LOOK FOR TEST RESULTS IN VARIABLE G 28 ; ACTUALLY, IF NO CCR IS THERE, IT WILL PUT ONE THERE FOR PAT DFN 2 29 ; 30 N GPLCCR S GPLCCR=$NA(^GPL("CCR")) 31 I '$D(@GPLCCR@(1)) D ; NO CCR THERE 32 . N TGPL 33 . D CCRRPC^C0CCCR(.TGPL,2) ; GET A CCR FOR PAT 2 34 . M @GPLCCR=TGPL ; PUT IT IN THE TEST GLOBAL 35 . K @GPLCCR@(0) ; KILL THE LINE COUNT FOR THE PARSER 36 D EN(.G,GPLCCR) 37 Q 38 ; 39 EN(ZRTN,C0CIN) ; PARSE THE CCR PASSED BY NAME IN C0CIN 40 ; AND RETURN THE XPATH ARRAY THAT RESULTS IN ZRTN, PASSED BY REFERENCE 41 I '$D(@C0CIN@(1)) Q ;NOTHING PASSED IN 42 K ZRTN 43 N C0CDOCID,REDUX,GARY,GARY2,GARY3 44 S C0CDOCID=$$PARSE(C0CIN) 45 S REDUX="//ContinuityOfCareRecord/Body" 46 D XPATH(1,"/","GIDX","GARY",,REDUX) 47 D SEPARATE^C0CMCCD("GARY2","GARY") 48 S ZI="" 49 F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; 50 . N GTMP,G2 51 . M G2=GARY2(ZI) 52 . D DEMUX2^C0CMXP("GTMP","G2",2) 53 . M GARY3(ZI)=GTMP 54 M ZRTN=GARY3 55 Q 56 ; 57 TEST0 ; 58 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 59 K GARY 60 M @C0CXMLIN=^GPL("CCR") 61 ;W $$FTG^%ZISH("/home/vademo2/CCR/","PAT_774_CCR_V1_0_0.xml",$NA(@C0CXMLIN@(1)),3) 62 S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DocID: ",C0CDOCID 63 S REDUX="//ContinuityOfCareRecord/Body" 64 D XPATH(1,"/","GIDX","GARY",,REDUX) 65 D SEPARATE^C0CMCCD("GARY2","GARY") 66 S ZI="" 67 F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; 68 . N GTMP,G2 69 . M G2=GARY2(ZI) 70 . D DEMUX2^C0CMXP("GTMP","G2",2) 71 . M GARY3(ZI)=GTMP 72 Q 73 ; 74 TEST2 ; 75 S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail" 76 D XPATH(1,"/","GIDX","GARY","",REDUX) 77 Q 78 ; 79 TEST3 80 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 81 K GARY,GTMP,GIDX 82 K @C0CXMLIN 83 W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) 84 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 85 K @C0CXMLIN 86 M @C0CXMLIN=GTMP 87 K GTMP 88 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 89 K @C0CXMLIN 90 M @C0CXMLIN=GTMP 91 K GTMP 92 S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID 93 S REDUX="//ClinicalDocument/component/structuredBody" 94 D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS 95 D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS 96 D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS 97 D XPATH(1,"/","GIDX","GARY",,REDUX) 98 K C0CCBK("TAG") 99 D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING 100 D TEST3A 101 Q 102 ; 103 TEST3A ; INTERNAL ROUTINE 104 S ZI="" 105 F S ZI=$O(GARY2(ZI)) Q:ZI="" D ; 106 . N GTMP,G2 107 . M G2=GARY2(ZI) 108 . D DEMUX2^C0CMXP("GTMP","G2",2) 109 . M GARY4(ZI)=GTMP 110 Q 111 ; 112 TESTQ ; TEST OF THE QRDA TEMPLATE GPL 7/8/2010 113 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 114 K GARY,GTMP,GIDX 115 K @C0CXMLIN 116 W $$FTG^%ZISH("/home/vademo2/","QRDA_CategoryI_WorldVistA1.xml",$NA(@C0CXMLIN@(1)),3) 117 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 118 K @C0CXMLIN 119 S GTMP(1)="<"_$P(GTMP(1),"<",2) 120 M @C0CXMLIN=GTMP 121 K GTMP 122 D TESTQ2 123 Q 124 ; 125 TESTQ2 ; SECOND PART OF TESTQ 126 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 127 K @C0CXMLIN 128 M @C0CXMLIN=GTMP 129 K GTMP 130 S C0CDOCID=$$PARSCCD^C0CMCCD(C0CXMLIN,"W") W !,"DocID: ",C0CDOCID 131 S REDUX="//ClinicalDocument/component/structuredBody" 132 D FINDTID^C0CMCCD ; FIND THE TEMPLATE IDS 133 D FINDALT^C0CMCCD ; FIND ALTERNATE TAGS 134 D SETCBK^C0CMCCD ; SET THE CALLBACK ROUTINE FOR TAGS 135 D XPATH(1,"/","GIDX","GARY",,REDUX) 136 K C0CCBK("TAG") 137 D SEPARATE^C0CMCCD("GARY2","GARY") ; SEPARATE FOR EASIER BROWSING 138 D TEST3A 139 Q 140 ; 141 TEST4 ; TEST OF OUTPUTING AN XML FILE FROM THE DOM .. this one is the CCR 142 ; 143 D TEST ; SET UP THE DOM 144 D START^C0CMXMLB($$TAG(1),,"G") 145 D NDOUT($$FIRST(1)) 146 D END^C0CMXMLB ;END THE DOCUMENT 147 M ZCCR=^TMP("MXMLBLD",$J) 148 ZWR ZCCR 149 Q 150 ; 151 TEST5 ; SAME AS TEST4, BUT THIS TIME THE CCD 152 S C0CXMLIN=$NA(^TMP("C0CMXML",$J)) 153 K GARY,GTMP,GIDX 154 K @C0CXMLIN 155 W $$FTG^%ZISH("/home/vademo2/CCR/","SampleCCDDocument.xml",$NA(@C0CXMLIN@(1)),3) 156 D CLEANARY^C0CMCCD("GTMP",C0CXMLIN) ; REMOVE CONTROL CHARACTERS 157 K @C0CXMLIN 158 M @C0CXMLIN=GTMP 159 K GTMP 160 D STRIPTXT^C0CMCCD("GTMP",C0CXMLIN) 161 K @C0CXMLIN 162 M @C0CXMLIN=GTMP 163 K GTMP 164 S C0CDOCID=$$PARSE(C0CXMLIN) W !,"DOCID: ",C0CDOCID ;CALL REGULAR PARSER 165 ;D XPATH(1,"/","GIDX2","GARY2",,REDUX) 166 D OUTXML("ZCCD",C0CDOCID) 167 ;D START^C0CMXMLB($$TAG(1),,"G") 168 ;D NDOUT($$FIRST(1)) 169 ;D END^C0CMXMLB ;EOND THE DOCUMENT 170 ;M ZCCD=^TMP("MXMLBLD",$J) 171 ZWR ZCCD(1:30) 172 Q 173 ; 174 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 175 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 176 ; THE XPATH ARRAY XPARY, PASSED BY NAME 177 ; ZOID IS THE STARTING OID 178 ; ZPATH IS THE STARTING XPATH, USUALLY "/" 179 ; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE 180 ; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT 181 I $G(ZREDUX)="" S ZREDUX="" 182 N NEWPATH 183 N NEWNUM S NEWNUM="" 184 I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]" 185 S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE 186 I $G(ZREDUX)'="" D ; REDUX PROVIDED? 187 . N GT S GT=$P(NEWPATH,ZREDUX,2) 188 . I GT'="" S NEWPATH=GT 189 S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX 190 N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE 191 I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY 192 E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY 193 N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD 194 I ZFRST'=0 D ; THERE IS A CHILD 195 . N ZNUM 196 . N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE 197 . D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD 198 N GNXT S GNXT=$$NXTSIB(ZOID) 199 I $$TAG(GNXT)'=$$TAG(ZOID) S ZNUM="" ; RESET COUNTING AFTER MULTIPLES 200 I GNXT'=0 D ; 201 . N ZMULT S ZMULT=$$ISMULT(GNXT) ; IS THE SIBLING A MULTIPLE? 202 . I (ZNUM="")&(ZMULT) D ; SIBLING IS FIRST OF MULTIPLES 203 . . N ZNUM S ZNUM=1 ; 204 . . D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; DO NEXT SIB 205 . E D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB 206 Q 207 ; 208 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 209 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 210 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML 211 ;Q $$EN^MXMLDOM(INXML) 212 Q $$EN^MXMLDOM(INXML,"W") 213 ; 214 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 215 N ZN 216 ;I $$TAG(ZOID)["entry" B 217 S ZN=$$NXTSIB(ZOID) 218 I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG 219 Q 0 220 ; 221 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 222 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 223 ; 224 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 225 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 226 ; 227 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 228 S HANDLE=C0CDOCID 229 K @RTN 230 D GETTXT^MXMLDOM("A") 231 Q 232 ; 233 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 234 ;I ZOID=149 B ;GPLTEST 235 N X,Y 236 S Y="" 237 S X=$G(C0CCBK("TAG")) ;IS THERE A CALLBACK FOR THIS ROUTINE 238 I X'="" X X ; EXECUTE THE CALLBACK, SHOULD SET Y 239 I Y="" S Y=$$NAME^MXMLDOM(C0CDOCID,ZOID) 240 Q Y 241 ; 242 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 243 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 244 ; 245 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 246 ;N ZT,ZN S ZT="" 247 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) 248 ;Q $G(@C0CDOM@(ZOID,"T",1)) 249 S ZN=$$TEXT^MXMLDOM(C0CDOCID,ZOID,ZT) 250 Q 251 ; 252 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 253 ; 254 S C0CDOCID=INID 255 D START^C0CMXMLB($$TAG(1),,"G") 256 D NDOUT($$FIRST(1)) 257 D END^C0CMXMLB ;END THE DOCUMENT 258 M @ZRTN=^TMP("MXMLBLD",$J) 259 K ^TMP("MXMLBLD",$J) 260 Q 261 ; 262 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 263 N ZI S ZI=$$FIRST(ZOID) 264 I ZI'=0 D ; THERE IS A CHILD 265 . N ZATT D ATT("ZATT",ZOID) ; THESE ARE THE ATTRIBUTES MOVED TO ZATT 266 . D MULTI^C0CMXMLB("",$$TAG(ZOID),.ZATT,"NDOUT^C0CMXML(ZI)") ;HAVE CHILDREN 267 E D ; NO CHILD - IF NO CHILDREN, A NODE HAS DATA, IS AN ENDPOINT 268 . ;W "DOING",ZOID,! 269 . N ZD D DATA("ZD",ZOID) ;NODES WITHOUT CHILDREN HAVE DATA 270 . N ZATT D ATT("ZATT",ZOID) ;ATTRIBUTES 271 . D ITEM^C0CMXMLB("",$$TAG(ZOID),.ZATT,$G(ZD(1))) ;NO CHILDREN 272 I $$NXTSIB(ZOID)'=0 D ; THERE IS A SIBLING 273 . D NDOUT($$NXTSIB(ZOID)) ;RECURSE FOR SIBLINGS 274 Q 275 ; 276 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 277 K ZERR 278 D CLEAN^DILF 279 D UPDATE^DIE("","C0CFDA","","ZERR") 280 I $D(ZERR) D ; 281 . W "ERROR",! 282 . ZWR ZERR 283 . B 284 K C0CFDA 285 Q 286 ; 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate;Build 38 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/trunk/p/C0CMXMLB.m
r607 r1204 6 6 ;DOCTYPE - Want to include a DOCTYPE node 7 7 ;FLAG - Set to 'G' to store the output in the global ^TMP("MXMLBLD",$J, 8 START(DOC,DOCTYPE,FLAG ) ;Call this once at the begining.8 START(DOC,DOCTYPE,FLAG,NO1ST) ;Call this once at the begining. 9 9 K ^TMP("MXMLBLD",$J) 10 10 S ^TMP("MXMLBLD",$J,"DOC")=DOC,^TMP("MXMLBLD",$J,"STK")=0 11 11 I $G(FLAG)["G" S ^TMP("MXMLBLD",$J,"CNT")=1 12 D OUTPUT($$XMLHDR) D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">") 12 I $G(NO1ST)'=1 D OUTPUT($$XMLHDR) 13 D:$L($G(DOCTYPE)) OUTPUT("<!DOCTYPE "_DOCTYPE_">") D OUTPUT("<"_DOC_">") 13 14 Q 14 15 ; … … 41 42 Q S 42 43 ; 43 Q(X) ;Add Quotes 44 I X'[$C(34) Q $C(34)_X_$C(34) 45 N Q,Y,I,Z S Q=$C(34),(Y,Z)="" 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)="" 46 49 F I=1:1:$L(X,Q)-1 S Y=Y_$P(X,Q,I)_Q_Q 47 50 S Y=Y_$P(X,Q,$L(X,Q)) 48 Q $C(34)_Y_$C(34) 51 ;Q $C(34)_Y_$C(34) 52 Q $C(39)_Y_$C(39) 49 53 ; 50 54 XMLHDR() ; -- provides current XML standard header -
ccr/trunk/p/C0CMXP.m
r763 r1204 1 1 C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 2 ;;0.1;C0C;nopatch;noreleasedate 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 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 2 ;;0.1;C0C;nopatch;noreleasedate;Build 38 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 282 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 283 284 285 286 287 288 289 290 291 292 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/trunk/p/C0CNHIN.m
r1203 r1204 19 19 ; 20 20 Q 21 EN(ZRTN,ZDFN ) ; GENERATE AN NHIN ARRAY FOR A PATIENT21 EN(ZRTN,ZDFN,ZPART,KEEP) ; GENERATE AN NHIN ARRAY FOR A PATIENT 22 22 ; 23 23 K GARY,GNARY,GIDX,C0CDOCID … … 26 26 K ^TMP("MXMLDOM",$J) ; CLEAN UP DOM 27 27 K ^TMP("MXMLERR",$J) ; CLEAN UP MXML ERRORS 28 D GET^NHINV(.GN,ZDFN ) ; CALL NHINV ROUTINES TO PULL XML28 D GET^NHINV(.GN,ZDFN,ZPART) ; CALL NHINV ROUTINES TO PULL XML 29 29 S GN=$P(GN,")",1)_")" ; CUT OFF THE REST OF LINE PROTOCOL 30 30 S C0CDOCID=$$PARSE(GN,"NHINARRAY") ; PARSE WITH MXML 31 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 32 68 Q 33 69 ; … … 59 95 Q 60 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 ; 61 107 CCD ; TRY IT WITH A CCD 62 108 ; … … 74 120 K GARY,GIDX,C0CDOCID 75 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")) 76 144 S C0CDOCID=$$PARSE(GN,"GPLTEST") 77 145 D DOMO^C0CDOM(C0CDOCID,"/","GNARY","GIDX","GARY",,"/results/") -
ccr/trunk/p/C0CPARMS.m
r974 r1204 1 1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 20 SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS 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 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 I '$D(@C0CPARMS@("LABLIMIT")) S @C0CPARMS@("LABLIMIT")="T-360" ;ONE YR WORTH 41 I '$D(@C0CPARMS@("LABSTART")) S @C0CPARMS@("LABSTART")="T" ;TODAY 42 I '$D(@C0CPARMS@("VITLIMIT")) S @C0CPARMS@("VITLIMIT")="T-360" ;ONE YR VITALS 43 I '$D(@C0CPARMS@("VITSTART")) S @C0CPARMS@("VITSTART")="T" ;TODAY 44 I '$D(@C0CPARMS@("MEDSTART")) S @C0CPARMS@("MEDSTART")="T" ; TODAY 45 I '$D(@C0CPARMS@("MEDSLIMIT")) S @C0CPARMS@("MEDLIMIT")="T-360" ; ONE YR MEDS 46 I '$D(@C0CPARMS@("MEDACTIVE")) S @C0CPARMS@("MEDACTIVE")=1 ; YES 47 I '$D(@C0CPARMS@("MEDPENDING")) S @C0CPARMS@("MEDPENDING")=0 ; NO 48 I '$D(@C0CPARMS@("MEDALL")) S @C0CPARMS@("MEDALL")=0 ; NON-PENDING NON-ACTIVE 49 Q 50 ; 51 51 CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET 52 53 54 55 56 52 ; 53 I '$D(C0CPARMS) S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;SHOULDN'T HAPPEN 54 I '$D(@C0CPARMS) D SET("SETWITHCHECK:1") 55 Q 56 ; 57 57 GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP 58 59 60 61 62 58 ; 59 D CHECK ; SHOULDN'T HAPPEN BUT TO BE SAFE 60 N GTMP 61 Q $G(@C0CPARMS@(WHICHP)) ;PULL THE PARM FROM THE TABLE 62 ; -
ccr/trunk/p/C0CPROBS.m
r762 r1204 1 C0CPROBS 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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 VISTA 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 CCD 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 MISSINGVARS 173 174 175 176 177 178 179 180 1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") 63 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") 64 . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 65 . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 66 . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 67 . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 68 . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 69 . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 70 . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 71 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") 72 . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 73 . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 74 . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 75 . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 76 . S ARYTMP=$NA(@TARYTMP@(J)) 77 . ; W "ARYTMP= ",ARYTMP,! 78 . K @ARYTMP 79 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 80 . I J=1 D ; FIRST ONE IS JUST A COPY 81 . . ; W "FIRST ONE",! 82 . . D CP^C0CXPATH(ARYTMP,OUTXML) 83 . . ; W "OUTXML ",OUTXML,! 84 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 85 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 86 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 87 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 88 ; ZWR @OUTXML 89 ; $$HTML^DILF( 90 ; GENERATE THE NARITIVE HTML FOR THE CCD 91 I CCD D CCD ; IF THIS IS FOR A CCD 92 D MISSINGVARS 93 Q 94 ; 95 VISTA ; GETS THE PROBLEM LIST FOR VISTA 96 D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC 97 I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL 98 . W "NULL RESULT FROM LIST^ORQQPL3 ",! 99 . S @OUTXML@(0)=0 100 . ; Q 101 ; I DEBUG ZWR RPCRSLT 102 S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS 103 F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST 104 . S VMAP=$NA(@TVMAP@(J)) 105 . K @VMAP 106 . I DEBUG W "VMAP= ",VMAP,! 107 . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY 108 . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM 109 . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) 110 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") 111 . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG 112 . S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status 113 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) 114 . S @VMAP@("PROBLEMCODINGVERSION")="" 115 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) 116 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") 117 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") 118 . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) 119 . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) 120 . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) 121 . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) 122 . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) 123 . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) 124 . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 125 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) 126 . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) 127 . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) 128 . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") 129 . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") 130 . S ARYTMP=$NA(@TARYTMP@(J)) 131 . ; W "ARYTMP= ",ARYTMP,! 132 . K @ARYTMP 133 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 134 . I J=1 D ; FIRST ONE IS JUST A COPY 135 . . ; W "FIRST ONE",! 136 . . D CP^C0CXPATH(ARYTMP,OUTXML) 137 . . ; W "OUTXML ",OUTXML,! 138 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 139 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 140 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 141 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 142 ; ZWR @OUTXML 143 ; $$HTML^DILF( 144 ; GENERATE THE NARITIVE HTML FOR THE CCD 145 I CCD D CCD ; IF THIS IS FOR A CCD 146 D MISSINGVARS 147 Q 148 CCD 149 N HTMP,HOUT,HTMLO,C0CPROBI,ZX 150 F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM 151 . S VMAP=$NA(@TVMAP@(C0CPROBI)) 152 . I DEBUG W "VMAP =",VMAP,! 153 . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE 154 . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP 155 . ; D PARY^C0CXPATH("HTMP") ; PRINT IT 156 . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES 157 . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN 158 . I C0CPROBI=1 D ; FIRST ONE IS JUST A COPY 159 . . D CP^C0CXPATH("HOUT","HTMLO") 160 . I C0CPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML 161 . . I DEBUG W "DOING INNER",! 162 . . N HTMLBLD,HTMLTMP 163 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) 164 . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) 165 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) 166 . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP") 167 . . D CP^C0CXPATH("HTMLTMP","HTMLO") 168 . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//") 169 I DEBUG D PARY^C0CXPATH("HTMLO") 170 D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION 171 Q 172 MISSINGVARS 173 N PROBSTMP,I 174 D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS 175 I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - 176 . ; STRINGS MARKED AS @@X@@ 177 . W !,"PROBLEMS Missing list: ",! 178 . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! 179 Q 180 ; -
ccr/trunk/p/C0CPROC.m
r783 r1204 1 C0CPROC 2 ;;1.0;C0C;;Jan 21, 2010; 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 EXTRACT(PROCXML,DFN,PROCOUT) 31 32 33 34 35 36 37 38 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 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 PRV(IARY) 92 93 94 95 96 97 98 99 DATE(ISTR) 100 101 102 CPT(ISTR) 103 104 105 106 107 108 109 110 111 112 113 114 115 116 MAP(PROCXML,C0CPRC,PROCOUT) 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.0;C0C;;Jan 21, 2010;Build 38 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 Q 29 ; 30 EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE 31 ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 32 ; 33 D SETVARS ; SET UP VARIABLES 34 I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE 35 D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES 36 Q 37 ; 38 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 39 ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 40 ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES 41 ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT 42 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 43 ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM 44 ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS 45 ; 46 K VISIT,LST,NOTE,C0CLPRC 47 ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS 48 ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES 49 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 50 ; NEED TO ADD START AND END DATES FROM PARAMETERS 51 N ZI S ZI="" 52 N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" 53 F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST 54 . N ZDATE 55 . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) 56 . S ZPRVARY=$NA(VISIT(ZI,"PRV")) 57 . N ZPRV 58 . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM 59 . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 60 . N ZJ S ZJ="" 61 . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG 62 . . N ZRNF 63 . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT 64 . . I ZCPT'="" D ;IF CPT CODE IS PRESENT 65 . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED 66 . . . W !,ZCPT," ",ZDATE," ",ZPRV 67 . . . S ZRNF("PROCACTOROBJID")=ZPRV 68 . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) 69 . . . S ZRNF("PROCCODE")=PROCCODE 70 . . . S ZRNF("PROCCODESYS")="CPT-4" 71 . . . S ZRNF("PROCDATETEXT")="Procedure Date" 72 . . . S ZRNF("PROCDATETIME")=ZDATE 73 . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET 74 . . . S ZRNF("PROCDESCOBJATTR")="" 75 . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES 76 . . . S ZRNF("PROCDESCOBJATTRVAL")="" 77 . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) 78 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET 79 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET 80 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ 81 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS 82 . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? 83 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE 84 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 85 . . . S PREVCPT=ZCPT 86 . . . S PREVDT=ZDATE 87 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) 88 M @ZRIM=@C0CPRC@("V") 89 Q 90 ; 91 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME 92 N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" 93 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG 94 . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER 95 . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) 96 I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR 97 Q ZRTN 98 ; 99 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT 100 Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") 101 ; 102 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS 103 ; CPT^CATEGORY^TEXT 104 N Z1,Z2,Z3,ZRTN 105 S Z1=$P(ISTR,U,1) 106 I Z1="" D ; 107 . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) 108 I Z1'="" D ; IF THERE IS A CPT CODE IN THERE 109 . ;S Z1=$P(ISTR,U,1) 110 . S Z2=$P(ISTR,U,2) 111 . S Z3=$P(ISTR,U,3) 112 . S ZRTN=Z1_U_Z2_U_Z3 113 E S ZRTN="" 114 Q ZRTN 115 ; 116 MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML 117 ; 118 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE 119 K @ZTEMP 120 N ZBLD 121 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA 122 D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE 123 N ZINNER 124 D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC 125 N ZTMP,ZVAR,ZI 126 S ZI="" 127 F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE 128 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML 129 . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES 130 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 131 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 132 D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) 133 N ZZTMP 134 D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML 135 K @ZTEMP,@ZBLD,@C0CPRC 136 Q 137 ; -
ccr/trunk/p/C0CRIMA.m
r713 r1204 1 1 C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 39 ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE 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 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 110 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS 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 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 154 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES 155 156 157 158 155 K ^TMP("C0CRIM","RESUME") 156 K ^TMP("C0CRIM") 157 Q 158 ; 159 159 CLIST ; LIST THE CATEGORIES 160 161 162 163 164 165 166 167 168 169 170 171 172 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 173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES 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 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 209 CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 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 234 CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 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 256 CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST 257 258 259 260 261 262 263 264 265 266 267 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 268 XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT 269 270 271 272 273 274 275 276 277 278 279 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 280 CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 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 296 PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT 297 298 299 300 301 302 303 304 305 306 307 308 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 309 APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) 310 311 312 313 314 315 316 317 318 319 320 321 322 323 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 324 ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL 325 326 327 328 329 330 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 331 AINIT ; INITIALIZE ATTRIBUTE TABLE 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 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 365 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL 366 367 368 369 370 371 372 373 374 375 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 376 GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 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 399 PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR 400 401 402 403 404 405 406 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 407 CAGET(RTN,IATTR) ; 408 409 410 411 412 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 413 PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR 414 415 416 417 S LSTRTN(0)=0 ; DEFAULT RETURN NONE418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 S ZPAT=""; START AT FIRST PATIENT IN LIST433 434 435 436 437 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 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 . D PARY^C0CXPATH("ZR") ; PRINT ARRAY 446 . W "COUNT=",ZR(0),! 447 Q 448 ; 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 ; 449 452 RPCGV(RTN,DFN,WHICH) ; RPC GET VARS 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 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 ; 467 470 ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 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 ; 486 489 DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM 487 488 489 490 491 492 493 494 495 496 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 ; 497 500 RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT 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 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 ; 523 526 RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE 524 525 526 527 528 529 530 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/trunk/p/C0CRNF.m
r891 r1204 1 1 C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE 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 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 103 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME 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 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 129 GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP 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 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 193 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP 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 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 257 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES 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 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 291 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX 292 293 294 295 296 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 297 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT 298 299 300 301 302 303 304 305 306 307 308 309 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 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 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 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 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 360 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV 361 362 363 364 365 366 367 368 369 370 371 372 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 373 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE 374 375 376 377 374 ; 375 W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) 376 Q 377 ; 378 378 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM 379 380 381 382 383 384 385 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 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 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 441 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 442 443 444 445 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 446 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 447 448 449 450 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 451 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 452 453 454 455 456 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 457 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED 458 459 460 461 462 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/trunk/p/C0CRXN.m
r508 r1204 1 1 C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 EXPAND ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112) 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 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 85 EXP2 ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE 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 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 160 CHKNDF ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB 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 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 255 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 256 257 258 259 260 261 262 263 264 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 265 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 266 267 268 269 270 271 272 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 273 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 274 275 276 277 278 279 280 281 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 282 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 283 284 285 286 287 288 289 290 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/trunk/p/C0CSOAP.m
r728 r1204 1 1 C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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 2 ;;1.0;C0C;;May 19, 2009;Build 38 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/trunk/p/C0CSUB1.m
r508 r1204 1 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 23 CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 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 45 SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 46 47 48 49 50 51 52 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 53 SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS 54 55 56 57 58 59 60 61 62 63 64 65 66 67 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 68 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 69 70 71 72 73 74 75 76 77 78 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 79 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 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 101 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 102 103 104 105 106 107 108 109 110 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 111 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 112 113 114 115 116 117 118 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 119 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 120 121 122 123 124 125 126 127 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 128 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 129 130 131 132 133 134 135 136 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/trunk/p/C0CSYS.m
r508 r1204 1 1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 29 SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic 30 31 32 30 Q:$G(DUZ("AG"))="I" "RPMS" 31 Q "WorldVistA EHR/VOE" 32 ; 33 33 SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic 34 35 34 Q "1.0" 35 ; 36 36 PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 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/trunk/p/C0CUNIT.m
r508 r1204 1 1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 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 47 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 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 70 ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST 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 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 106 TEST ; RUN ALL THE TEST CASES 107 108 109 110 111 112 113 114 115 116 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 117 GTSTS(GTZARY,RTN) ; return an array of test names 118 119 120 121 122 123 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 124 TESTALL(RNM) ; RUN ALL THE TESTS 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 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 143 TLIST(ZARY) ; LIST ALL THE TESTS 144 145 146 147 148 149 150 151 152 153 154 155 156 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 157 MEDS 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 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 174 PAT 175 176 177 178 179 180 181 182 183 184 185 186 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/trunk/p/C0CUTIL.m
r771 r1204 1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 ;;0.1;C0C;;Jun 15, 2008;Build 29 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. 1 C0CUTIL ;WV/C0C/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 ;;0.1;C0C;;Jun 15, 2008;Build 38 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 6 138 ; 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. 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 I ZRXN=309362 S ZRXN=213169 148 I ZRXN=855318 S ZRXN=855320 149 I ZRXN=197361 S ZRXN=212549 150 I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" 151 Q ZRSLT 11 152 ; 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 RPMS() ; Are we running on an RPMS system rather than Vista? 138 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service 139 VISTA() ; Are we running on Vanilla Vista? 140 Q $G(DUZ("AG"))="V" ; If User Agency is VA 141 WV() ; Are we running on WorldVista? 142 Q $G(DUZ("AG"))="E" ; Code for WV. 143 OV() ; Are we running on OpenVista? 144 Q $G(DUZ("AG"))="O" ; Code for OpenVista 145 153 RPMS() ; Are we running on an RPMS system rather than Vista? 154 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service 155 VISTA() ; Are we running on Vanilla Vista? 156 Q $G(DUZ("AG"))="V" ; If User Agency is VA 157 WV() ; Are we running on WorldVista? 158 Q $G(DUZ("AG"))="E" ; Code for WV. 159 OV() ; Are we running on OpenVista? 160 Q $G(DUZ("AG"))="O" ; Code for OpenVista 161 -
ccr/trunk/p/C0CVA200.m
r508 r1204 1 1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 25 FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC 26 27 28 29 30 31 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 32 GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC 33 34 35 36 37 38 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 39 MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC 40 41 42 43 44 45 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 46 SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC 47 48 49 50 51 52 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 53 TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC 54 55 56 57 58 59 60 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 61 NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC 62 63 64 65 66 67 68 69 70 71 72 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 73 SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC 74 75 76 77 78 79 80 81 82 83 84 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 85 ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC 86 87 88 89 86 ; INPUT: DUZ, but not needed really... here for future expansion 87 ; OUTPUT: At this point "Work" 88 Q "Work" 89 ; 90 90 ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 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 113 CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC 114 115 116 117 118 119 120 121 122 123 124 125 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 126 STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC 127 128 129 130 131 132 133 134 135 136 137 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 138 POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC 139 140 141 142 143 144 145 146 147 148 149 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 150 TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC 151 152 153 154 155 156 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 157 TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC 158 159 160 161 158 ; INPUT: DUZ ByVal 159 ; OUTPUT: String. 160 Q "Office" 161 ; 162 162 EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC 163 164 165 166 167 168 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/trunk/p/C0CVIT2.m
r714 r1204 1 C0CVIT2 2 ;;1.0;C0C;;Feb 16, 2010; 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.0;C0C;;Feb 16, 2010;Build 38 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/trunk/p/C0CXPAT0.m
r592 r1204 1 1 C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 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 2 ;;1.0;C0C;;May 19, 2009;Build 38 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/trunk/p/C0CXPATH.m
r943 r1204 1 1 C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 2 ;;1.0;C0C;;May 19, 2009; 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 2 ;;1.0;C0C;;May 19, 2009;Build 38 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 24 OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE 25 26 27 28 29 30 31 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 32 PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) 33 34 35 36 37 38 39 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 40 POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL 41 42 43 44 45 46 47 48 49 50 51 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 52 PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME 53 54 55 56 57 58 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 59 MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK 60 61 62 63 64 65 66 67 68 69 70 71 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 72 XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG 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 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 336 QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 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 360 XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH 361 362 363 364 361 ; INDEX WITH TWO PIECES START^FINISH 362 ; IDX IS PASSED BY NAME 363 Q $P(@IDX@(XPATH),"^",1) 364 ; 365 365 XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH 366 367 368 369 366 ; INDEX WITH TWO PIECES START^FINISH 367 ; IDX IS PASSED BY NAME 368 Q $P(@IDX@(XPATH),"^",2) 369 ; 370 370 START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX 371 372 373 374 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 375 FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX 376 377 378 376 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 377 Q $P(ISTR,";",3) 378 ; 379 379 ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX 380 381 382 380 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 381 Q $P(ISTR,";",1) 382 ; 383 383 BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 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 401 QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST 402 403 404 405 406 402 ; 403 I $G(DEBUG) W "QUEUEING ",BLST,! 404 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) 405 Q 406 ; 407 407 CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME 408 409 410 411 412 413 414 415 416 417 418 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 419 QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 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 439 QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 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 458 INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE 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 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 486 INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 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 506 INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST 507 508 509 510 511 512 513 514 515 516 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 517 REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 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 541 DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 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 557 MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN 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 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 599 DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE 600 601 602 600 ; 601 Q 602 ; 603 603 TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS 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 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 641 UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML 642 643 644 645 646 647 648 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 649 PARY(GLO,ZN) ;PRINT AN ARRAY 650 651 652 653 654 655 656 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 657 H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY 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 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 683 XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES 684 685 686 687 688 689 690 691 692 693 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 694 DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 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 710 TEST ; Run all the test cases 711 712 713 711 D TESTALL^C0CUNIT("C0CXPAT0") 712 Q 713 ; 714 714 ZTEST(WHICH) ; RUN ONE SET OF TESTS 715 716 717 718 719 720 715 N ZTMP 716 S DEBUG=1 717 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 718 D ZTEST^C0CUNIT(.ZTMP,WHICH) 719 Q 720 ; 721 721 TLIST ; LIST THE TESTS 722 723 724 725 726 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.
