- Timestamp:
- Jan 4, 2012, 9:39:08 PM (13 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 57 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) (1 diff)
-
C0CDOM.m (modified) (9 diffs)
-
C0CDPT.m (modified) (1 diff)
-
C0CENC.m (modified) (1 diff)
-
C0CENV.m (modified) (2 diffs)
-
C0CEVC.m (modified) (1 diff)
-
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)
-
C0CLA7DD.m (modified) (3 diffs)
-
C0CLA7Q.m (modified) (1 diff)
-
C0CLABS.m (modified) (1 diff)
-
C0CMAIL.m (modified) (1 diff)
-
C0CMAIL2.m (modified) (1 diff)
-
C0CMAIL3.m (modified) (1 diff)
-
C0CMCCD.m (modified) (2 diffs)
-
C0CMED.m (modified) (1 diff)
-
C0CMED1.m (modified) (1 diff)
-
C0CMED2.m (modified) (1 diff)
-
C0CMED3.m (modified) (1 diff)
-
C0CMED6.m (modified) (2 diffs)
-
C0CMXML.m (modified) (1 diff)
-
C0CMXP.m (modified) (1 diff)
-
C0CNHIN.m (modified) (9 diffs)
-
C0CNMED2.m (modified) (1 diff)
-
C0CORSLT.m (modified) (1 diff)
-
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)
-
C0CRXNRD.m (modified) (4 diffs)
-
C0CSOAP.m (modified) (1 diff)
-
C0CSUB1.m (modified) (1 diff)
-
C0CSYS.m (modified) (1 diff)
-
C0CUNIT.m (modified) (1 diff)
-
C0CUTIL.m (modified) (2 diffs)
-
C0CVA200.m (modified) (1 diff)
-
C0CVIT2.m (modified) (1 diff)
-
C0CVITAL.m (modified) (1 diff)
-
C0CVOBX1.m (modified) (1 diff)
-
C0CXPAT0.m (modified) (1 diff)
-
C0CXPATH.m (modified) (1 diff)
-
LA7QRY1.m (modified) (1 diff)
-
VWTIME.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/C0CACTOR.m
r1331 r1336 1 C0CACTOR 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 EXTRACT(IPXML,ALST,AXML) 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 PATIENT(INXML,AIEN,AOID,OUTXML) 86 87 88 89 90 91 92 93 94 95 96 97 98 99 DEIDENT(GPL,ZDFN) 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 PEXTRACT(AMAP,AIEN,AOID) 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 MAP(INXML,AMAP,OUTXML) 185 186 187 188 SYSTEM(INXML,AIEN,AOID,OUTXML) 189 190 191 192 193 194 195 196 197 198 199 200 NOK(INXML,AIEN,AOID,OUTXML) 201 202 203 204 205 206 207 208 209 210 211 212 213 ORG(INXML,AIEN,AOID,OUTXML) 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 PROVIDER(INXML,AIEN,AOID,OUTXML) 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 1 C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 2 ;;1.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
r1331 r1336 1 C0CALERT 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 PRSGLB(INGLB) 130 131 132 1 C0CALERT ; CCDCCR/CKU/GPL - CCR/CCD PROCESSING FOR ALERTS ; 09/11/08 2 ;;1.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 . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE 85 . I ACVUID'="" D ; IF VUID IS NOT NULL 86 . . S ZC=$$CODE^C0CUTIL(ACVUID) 87 . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 88 . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 89 . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 90 . E D ; IF REACTANT CODE VALUE IS NULL 91 . . I $G(DUZ("AG"))="I" D ; IF WE ARE RUNNING ON RPMS 92 . . . S ACTMP=$O(^C0CCODES(176.112,"C",ACNM,0)) ; 93 . . . W "RPMS NAME FOUND",ACNM," ",ACTMP,! 94 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")="" 95 . . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")="" 96 . S @ALTVMAP@("ALERTAGENTPRODUCTCODEVALUE")=ZCD 97 . S @ALTVMAP@("ALERTAGENTPRODUCTCODESYSTEM")=ZCDS 98 . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM_" "_ZCDS_": "_ZCD 99 . S @ALTVMAP@("ALERTDESCRIPTIONTEXT")=ADT_" "_ZCDS_": "_ZCD 100 . ; REACTIONS - THIS SHOULD BE MULTIPLE, IS SINGLE NOW 101 . N ARTMP,ARIEN,ARDES,ARVUID 102 . S (ARTMP,ARDES,ARVUID)="" 103 . I $D(@ALTG@(ALTTMP,"S",1)) D ; IF REACTION EXISTS 104 . . S ARTMP=@ALTG@(ALTTMP,"S",1) 105 . . W "REACTION:",ARTMP,! 106 . . S ARIEN=$P(ARTMP,";",2) 107 . . S ARDES=$P(ARTMP,";",1) 108 . . S ARVUID=$$GET1^DIQ(120.83,ARIEN,"VUID") 109 . S @ALTVMAP@("ALERTREACTIOINDESCRIPTIONTEXT")=ARDES 110 . I ARVUID'="" D ; IF REACTION VUID IS NOT NULL 111 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")=ARVUID 112 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="VUID" 113 . E D ; IF IT IS NULL DON'T SET CODE SYSTEM 114 . . S @ALTVMAP@("ALERTREACTIONCODEVALUE")="" 115 . . S @ALTVMAP@("ALERTREACTIONCODESYSTEM")="" 116 . S ALTARYTMP=$NA(@ALTTARYTMP@(ALTCNT)) 117 . ; NOW GO TO THE GLOBAL TO GET THE DATE/TIME AND BETTER DESCRIPTION 118 . N C0CG1,C0CT ; ARRAY FOR VALUES FROM GLOBAL 119 . D GETN1^C0CRNF("C0CG1",120.8,ALTTMP,"") ;GET VALUES BY NAME 120 . S C0CT=$$ZVALUEI^C0CRNF("ORIGINATION DATE/TIME","C0CG1") 121 . S @ALTVMAP@("ALERTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CT,"DT") 122 . K @ALTARYTMP 123 . D MAP^C0CXPATH(ALTXML,ALTVMAP,ALTARYTMP) 124 . I ALTCNT=1 D CP^C0CXPATH(ALTARYTMP,ALTOUTXML) 125 . I ALTCNT>1 D INSINNER^C0CXPATH(ALTOUTXML,ALTARYTMP) 126 . S ALTCNT=ALTCNT+1 127 S @ALTTVMAP@(0)=ALTCNT-1 ; RECORD THE NUMBER OF ALERTS 128 Q 129 PRSGLB(INGLB) ; EXTRINSIC TO PARSE GLOBALS AND RETURN THE FILE NUMBER 130 ; INGLB IS OF THE FORM: PSNDF(50.6, 131 ; RETURN 50.6 132 Q $P($P(INGLB,"(",2),",",1) ; -
ccr/trunk/p/C0CBAT.m
r1331 r1336 1 C0CBAT 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 STOP 24 25 26 27 28 29 30 31 32 33 34 35 START 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 EN 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 BLDHOT(ZHB) 149 150 151 152 153 154 155 156 157 158 COUNT(ZB) 159 160 161 162 163 164 165 166 UPDIEVARPTR(ZVAR,ZTYP) 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 UPDIE 189 190 191 192 193 194 195 196 197 198 199 SETFDA(C0CSN,C0CSV) 200 201 202 203 204 205 206 207 208 209 ZFILE(ZFN,ZTAB) 210 211 212 213 214 215 216 217 ZFIELD(ZFN,ZTAB) 218 219 220 221 222 223 224 225 226 ZVALUE(ZFN,ZTAB) 227 228 229 230 231 232 233 234 1 C0CBAT ; CCDCCR/GPL - CCR Batch utilities; 4/21/09 2 ;;1.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 STOP ; STOP A CURRENTLY RUNNING BATCH JOB 24 I '$D(^TMP("C0CBAT","RUNNING")) Q ; 25 W !,!,"HALTING CCR BATCH",! 26 S ^TMP("C0CBAT","STOP")="" ; SIGNAL JOB TO TERMINATE 27 H 10 ; WAIT TEN SECONDS FOR SIGNAL TO BE RECEIVED 28 I '$D(^TMP("C0CBAT","STOP")) D ; SIGNAL RECEIVED 29 . W "CCR BATCH JOB TERMINATING",! 30 E D ; 31 . K ^TMP("C0CBAT","STOP") ; STOP SIGNALING 32 . W !,"BATCH PROCESSING APPARENTLY NOT RUNNING",! 33 Q 34 ; 35 START ; STARTS A TAKSMAN CCR BATCH JOB - FOR USE IN A MENU OPTION 36 ; 37 I $D(^TMP("C0CBAT","RUNNING")) D Q ; ONLY ONE ALLOWED AT A TIME 38 . W !,"CCR BATCH ALREADY RUNNING",! 39 . W !,"STOP FIRST WITH STOP^C0CBAT",! 40 N ZTRTN,ZTDESC,ZTDTH,ZTSAVE,ZTSK,ZTIO 41 S ZTRTN="EN^C0CBAT",ZTDESC="CCR Batch" 42 S ZTDTH=$H ; 43 ;S ZTDTH=$S(($P(ZTDTH,",",2)+10)\86400:(1+ZTDTH)_","_((($P(ZTDTH,",",2)+10)#86400)/100000),1:(+ZTDTH)_","_($P(ZTDTH,",",2)+10)) 44 S ZTSAVE("C0C")="",ZTSAVE("C0C*")="" 45 S ZTIO="NULL" ; 46 W !,!,"CCR BATCH JOB STARTED",! 47 D ^%ZTLOAD 48 Q 49 ; 50 EN ; BATCH ENTRY POINT 51 ; PROCESSES THE SUBSCRIPTION FILE, EXTRACTING CCR VARIABLES FOR EACH 52 ; PATIENT WITH AN ACTIVE SUBSCRIPTION, AND IF CHECKSUMS INDICATE A CHANGE, 53 ; GENERATES A NEW CCR FOR THE PATIENT 54 ; UPDATES THE E2 CCR ELEMENTS FILE 55 ; 56 S C0CQT=1 ; QUIET MODE 57 I $D(^TMP("C0CBAT","RUNNING")) Q ; ONLY ONE AT A TIME 58 S ^TMP("C0CBAT","RUNNING")="" ; RUNNING SIGNAL 59 S C0CBDT=$$NOW^XLFDT ; DATE OF THIS RUN 60 S C0CBF=177.301 ; FILE NUMBER OF C0C BATCH CONTROL FILE 61 S C0CBFR=177.3013 ; FILE NUMBER OF UPDATE SUBFILE 62 S C0CBB=$NA(^TMP("C0CBATCH",C0CBDT)) ; BATCH WORK AREA 63 I $D(@C0CBB@(0)) D ; ERROR SHOULDN'T EXIST 64 . W "WORK AREA ERROR",! 65 . B 66 S @C0CBB@(0)="V22" ; VERSION USED TO CREATE THIS WORK AREA 67 S C0CBH=$NA(@C0CBB@("HOTLIST")) ; BASE FOR HOT LIST 68 S C0CBS=$NA(^C0CS("B")) ; SUBSCRIPTION LIST BASE 69 ;I $D(^C0CB("B",C0CDT)) D ; BATCH RECORD EXISTS 70 ;. H 10 ; HANG 10 SECONDS 71 ;. S C0CBDT=$$NOW^XLFDT ; NEW DATE FOR THIS RUN 72 ;. I $D(^C0CB("B",C0CDT)) B ;DIDN'T WORK 73 D BLDHOT(C0CBH) ; BUILD THE HOT LIST 74 S C0CHN=$$COUNT(C0CBH) ;COUNT NUMBER IN HOT LIST 75 S C0CSN=$$COUNT(C0CBS) ;COUNT NUMBER OF PATIENTS WITH SUBSCRIPTIONS 76 S C0CFDA(C0CBF,"+1,",.01)=C0CBDT ; DATE KEY OF BATCH CONTROL 77 S C0CFDA(C0CBF,"+1,",.02)=C0CBDT ; BATCH ID IS DATE IN STRING FORM 78 S C0CFDA(C0CBF,"+1,",1)=C0CSN ; TOTAL SUBSCRIPTIONS 79 S C0CFDA(C0CBF,"+1,",2)=C0CHN ; TOTAL HOT LIST 80 D UPDIE ; CREATE THE BATCH RECORD 81 S C0CIEN=$O(^C0CB("B",C0CBDT,"")) 82 S (C0CN,C0CNH)=0 ; COUNTERS FOR TOTAL AND HOT LIST 83 S C0CBCUR="" ; CURRENT PATIENT 84 S C0CSTOP=0 ; STOP FLAG FOR HALTING BATCH SET ^TMP("C0CBAT","STOP")="" 85 ;F S C0CBCUR=$O(@C0CBH@(C0CBCUR),-1) Q:C0CBCUR="" D ; HOT LIST LATEST FIRST 86 F S C0CBCUR=$O(@C0CBH@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; HOT LIST FIRST 87 . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-900^VITLIMIT:T-900") 88 . I $G(C0CCHK) D ; 89 . . D PUTRIM^C0CFM2(C0CBCUR) 90 . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR 91 . . K C0CFDA 92 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR 93 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" 94 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) 95 . . D UPDIE ; CREATE UPDATE SUBFILE 96 . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL 97 . S C0CNH=C0CNH+1 ; INCREMENT HOT LIST TOTAL 98 . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS 99 . S C0CFDA(C0CBF,C0CIEN_",",2.1)=C0CNH ; UPDATE HOT LIST PROGRESS 100 . S C0CNOW=$$NOW^XLFDT 101 . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD 102 . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS 103 . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME 104 . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME 105 . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 106 . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START 107 . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME 108 . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; LAST RECORD PROCESSED 109 . D UPDIE ; 110 . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED 111 . . S C0CSTOP=1 112 . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 113 . H 1 ; GIVE OTHERS A CHANCE 114 F S C0CBCUR=$O(@C0CBS@(C0CBCUR)) Q:(C0CSTOP)!(C0CBCUR="") D ; SUBS LIST 115 . I $D(@C0CBH@(C0CBCUR)) Q ; SKIP IF IN HOT LIST - ALREADY DONE 116 . D ANALYZE^C0CRIMA(C0CBCUR,1,"LABLIMIT:T-760^VITLIMIT:T-760") 117 . I $G(C0CCHK) D ; IF CHECKSUMS HAVE CHANGED 118 . . D PUTRIM^C0CFM2(C0CBCUR) 119 . . D XPAT^C0CCCR(C0CBCUR) ; IF VARIABLES HAVE CHANGED GENERATE CCR 120 . . K C0CFDA 121 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",.01)=C0CBCUR 122 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",1)="Y" 123 . . S C0CFDA(C0CBFR,"+1,"_C0CIEN_",",2)=$G(^TMP("C0CCCR","FNAME",C0CBCUR)) 124 . . D UPDIE ; CREATE UPDATE SUBFILE 125 . S C0CN=C0CN+1 ; INCREMENT NUMBER IN TOTAL 126 . S C0CFDA(C0CBF,C0CIEN_",",1.1)=C0CN ;UPDATE TOTAL PROGRESS 127 . S C0CNOW=$$NOW^XLFDT 128 . S C0CFDA(C0CBF,C0CIEN_",",4)=C0CNOW ; LAST UPDATED FIELD 129 . S C0CELPS=$$FMDIFF^XLFDT(C0CNOW,C0CBDT,2) ; DIFFERENCE IN SECONDS 130 . S C0CAVG=C0CELPS/C0CN ; AVERAGE ELAPSED TIME 131 . S C0CFDA(C0CBF,C0CIEN_",",4.1)=C0CAVG ; AVERAGE ELAPSED TIME 132 . S C0CETOT=C0CAVG*C0CSN ; EST TOT ELASPSED TIME 133 . S C0CEST=$$FMADD^XLFDT(C0CBDT,0,0,0,C0CETOT) ; ADD SECONDS TO BATCH START 134 . S C0CFDA(C0CBF,C0CIEN_",",4.2)=C0CEST ;ESTIMATED COMPLETION TIME 135 . S C0CFDA(C0CBF,C0CIEN_",",5)=C0CBCUR ; 136 . D UPDIE ; 137 . I $D(^TMP("C0CBAT","STOP")) D ; IF STOP SIGNAL DETECTED 138 . . S C0CSTOP=1 139 . . K ^TMP("C0CBAT","STOP") ; SIGNAL RECEIVED 140 . H 1 ; GIVE IT A BREAK 141 I (C0CSTOP) S C0CDISP="KILLED" 142 E S C0CDISP="FINISHED" 143 S C0CFDA(C0CBF,C0CIEN_",",6)=C0CDISP 144 D UPDIE ; SET DISPOSITION FIELD 145 K ^TMP("C0CBAT","RUNNING") 146 Q 147 ; 148 BLDHOT(ZHB) ; BUILD HOT LIST AT GLOBAL ZHB, PASSED BY NAME 149 ; SEARCHS FOR PATIENTS IN THE "AC" INDEX OF THE ORDER FILE 150 N ZDFN 151 S ZDFN="" 152 F S ZDFN=$O(^OR(100,"AC",ZDFN)) Q:ZDFN="" D ; ALL PATIENTS IN THE AC INDX 153 . S ZZDFN=$P(ZDFN,";",1) ; FORMAT IS "N;DPT(" 154 . I '$D(@C0CBS@(ZZDFN)) Q ; SKIP IF NOT IN SUBSCRIPTION LIST 155 . S @ZHB@(ZZDFN)="" ;ADD PATIENT TO THE HOT LIST 156 Q 157 ; 158 COUNT(ZB) ; EXTRINSIC THAT RETURNS THE NUMBER OF ARRAY ELEMENTS 159 N ZI,ZN 160 S ZN=0 161 S ZI="" 162 F S ZI=$O(@ZB@(ZI)) Q:ZI="" D ; 163 . S ZN=ZN+1 164 Q ZN 165 ; 166 UPDIEVARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 167 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 168 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 169 ; 170 N ZCCRD,ZVARN,C0CFDA2 171 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 172 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 173 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 174 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 175 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 176 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 177 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 178 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 179 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 180 . I $D(ZERR) D ; LAYGO ERROR 181 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 182 . E D ; 183 . . D CLEAN^DILF ; CLEAN UP 184 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 185 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 186 Q ZVARN 187 ; 188 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 189 K ZERR 190 D CLEAN^DILF 191 D UPDATE^DIE("","C0CFDA","","ZERR") 192 I $D(ZERR) D ; 193 . W "ERROR",! 194 . ZWR ZERR 195 . B 196 K C0CFDA 197 Q 198 ; 199 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 200 ; TO SET TO VALUE C0CSV. 201 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 202 ; C0CSN,C0CSV ARE PASSED BY VALUE 203 ; 204 N C0CSI,C0CSJ 205 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 206 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 207 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 208 Q 209 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 210 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 211 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 212 I '$D(ZTAB) S ZTAB="C0CA" 213 N ZR 214 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 215 E S ZR="" 216 Q ZR 217 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 218 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 219 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 220 I '$D(ZTAB) S ZTAB="C0CA" 221 N ZR 222 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 223 E S ZR="" 224 Q ZR 225 ; 226 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 227 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 228 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 229 I '$D(ZTAB) S ZTAB="C0CA" 230 N ZR 231 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 232 E S ZR="" 233 Q ZR 234 ; -
ccr/trunk/p/C0CCCD.m
r1331 r1336 1 C0CCCD 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXPORT 24 25 26 27 28 29 30 31 XPAT(DFN,DIR,FN) 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 INITSTPS(TAB) 149 150 151 152 153 154 155 156 157 SHAVE(SHXML) 158 159 160 161 162 163 164 165 166 167 168 169 170 UNSHAVE(ORIGXML,SHXML) 171 172 173 174 175 176 177 178 179 180 181 182 183 HDRMAP(CXML,DFN,IHDR) 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 ACTLST(AXML,ACTRTN) 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 TEST 228 229 230 231 ZTEST(WHICH) 232 233 234 235 236 237 TLIST 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 1 C0CCCD ; CCDCCR/GPL - CCD MAIN PROCESSING; 6/6/08 2 ;;1.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 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 ; Select a patient. 25 S DIC=2,DIC(0)="AEMQ" D ^DIC 26 I Y<1 Q ; EXIT 27 S DFN=$P(Y,U,1) ; SET THE PATIENT 28 D XPAT(DFN,"","") ; EXPORT TO A FILE 29 Q 30 ; 31 XPAT(DFN,DIR,FN) ; EXPORT ONE PATIENT TO A FILE 32 ; DIR IS THE DIRECTORY, DEFAULTS IF NULL TO ^TMP("C0CCCR","ODIR") 33 ; FN IS FILE NAME, DEFAULTS IF NULL 34 ; N CCDGLO 35 D CCDRPC(.CCDGLO,DFN,"CCD","","","") 36 S OARY=$NA(^TMP("C0CCCR",$J,DFN,"CCD",1)) 37 S ONAM=FN 38 I FN="" S ONAM="PAT_"_DFN_"_CCD_V1.xml" 39 S ODIRGLB=$NA(^TMP("C0CCCR","ODIR")) 40 I '$D(@ODIRGLB) D ; IF NOT ODIR HAS BEEN SET 41 . S @ODIRGLB="/home/glilly/CCROUT" 42 . ;S @ODIRGLB="/home/cedwards/" 43 . ;S @ODIRGLB="/opt/wv/p/" 44 S ODIR=DIR 45 I DIR="" S ODIR=@ODIRGLB 46 N ZY 47 S ZY=$$OUTPUT^C0CXPATH(OARY,ONAM,ODIR) 48 W $P(ZY,U,2) 49 Q 50 ; 51 CCDRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT 52 ; CCRGRTN IS RETURN ARRAY PASSED BY NAME 53 ; DFN IS PATIENT IEN 54 ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART 55 ; OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC 56 ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL 57 ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME 58 ; - NULL MEANS NOW 59 ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND 60 ; "TO" VARIABLES 61 ; IF NULL WILL DEFAULT TO "FROM" ORGANIZATION AND "TO" DFN 62 I '$D(DEBUG) S DEBUG=0 63 N CCD S CCD=0 ; FLAG FOR PROCESSING A CCD 64 I CCRPART="CCD" S CCD=1 ; WE ARE PROCESSING A CCD 65 S TGLOBAL=$NA(^TMP("C0CCCR",$J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE 66 I CCD S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCD")) ; GLOBAL FOR THE CCD 67 E S CCDGLO=$NA(^TMP("C0CCCR",$J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR 68 S ACTGLO=$NA(^TMP("C0CCCR",$J,DFN,"ACTORS")) ; GLOBAL FOR ALL ACTORS 69 ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC 70 S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL 71 I CCD D LOAD^C0CCCD1(TGLOBAL) ; LOAD THE CCR TEMPLATE 72 E D LOAD^C0CCCR0(TGLOBAL) ; LOAD THE CCR TEMPLATE 73 D CP^C0CXPATH(TGLOBAL,CCDGLO) ; COPY THE TEMPLATE TO CCR GLOBAL 74 N CAPSAVE,CAPSAVE2 ; FOR HOLDING THE CCD ROOT LINES 75 S CAPSAVE=@TGLOBAL@(3) ; SAVE THE CCD ROOT 76 S CAPSAVE2=@TGLOBAL@(@TGLOBAL@(0)) ; SAVE LAST LINE OF CCD 77 S @CCDGLO@(3)="<ContinuityOfCareRecord>" ; CAP WITH CCR ROOT 78 S @TGLOBAL@(3)=@CCDGLO@(3) ; CAP THE TEMPLATE TOO 79 S @CCDGLO@(@CCDGLO@(0))="</ContinuityOfCareRecord>" ; FINISH CAP 80 S @TGLOBAL@(@TGLOBAL@(0))="</ContinuityOfCareRecord>" ; FINISH CAP TEMP 81 ; 82 ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL 83 ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES 84 D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Body") 85 D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Actors") 86 I 'CCD D REPLACE^C0CXPATH(CCDGLO,"","//ContinuityOfCareRecord/Signatures") 87 I DEBUG F I=1:1:@CCDGLO@(0) W @CCDGLO@(I),! 88 ; 89 I 'CCD D HDRMAP(CCDGLO,DFN,HDRARY) ; MAP HEADER VARIABLES 90 ; MAPPING THE PATIENT PORTION OF THE CDA HEADER 91 S ZZX="//ContinuityOfCareRecord/recordTarget/patientRole/patient" 92 D QUERY^C0CXPATH(CCDGLO,ZZX,"ACTT1") 93 D PATIENT^C0CACTOR("ACTT1",DFN,"ACTORPATIENT_"_DFN,"ACTT2") ; MAP PATIENT 94 I DEBUG D PARY^C0CXPATH("ACTT2") 95 D REPLACE^C0CXPATH(CCDGLO,"ACTT2",ZZX) 96 I DEBUG D PARY^C0CXPATH(CCDGLO) 97 K ACTT1 K ACCT2 98 ; MAPPING THE PROVIDER ORGANIZATION,AUTHOR,INFORMANT,CUSTODIAN CDA HEADER 99 ; FOR NOW, THEY ARE ALL THE SAME AND RESOLVE TO ORGANIZATION 100 D ORG^C0CACTOR(CCDGLO,DFN,"ACTORPATIENTORGANIZATION","ACTT2") ; MAP ORG 101 D CP^C0CXPATH("ACTT2",CCDGLO) 102 ; 103 K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT 104 S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS 105 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS 106 N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD 107 F I=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS 108 . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE 109 . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL 110 . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL 111 . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE 112 . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS 113 . S IXML="INXML" 114 . I CCD D SHAVE(IXML) ; REMOVE ALL BUT REPEATING PARTS OF TEMPLATE SECTION 115 . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES 116 . ; W OXML,! 117 . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL 118 . W "RUNNING ",CALL,! 119 . X CALL 120 . I @OXML@(0)'=0 D ; THERE IS A RESULT 121 . . I CCD D QUERY^C0CXPATH(TGLOBAL,XPATH,"ITMP") ; XML TO UNSHAVE WITH 122 . . I CCD D UNSHAVE("ITMP",OXML) 123 . . I CCD D UNMARK^C0CXPATH(OXML) ; REMOVE THE CCR MARKUP FROM SECTION 124 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 125 . D INSERT^C0CXPATH(CCDGLO,OXML,"//ContinuityOfCareRecord/Body") 126 . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! 127 ; NEED TO ADD BACK IN ACTOR PROCESSING AFTER WE FIGURE OUT LINKAGE 128 ; D ACTLST^C0CCCR(CCDGLO,ACTGLO) ; GEN THE ACTOR LIST 129 ; D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") 130 ; D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") 131 ; D INSINNER^C0CXPATH(CCDGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 132 N I,J,DONE S DONE=0 133 F I=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE 134 . S J=$$TRIM^C0CXPATH(CCDGLO) ; DELETE EMPTY ELEMENTS 135 . W "TRIMMED",J,! 136 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE 137 I CCD D ; TURN THE BODY INTO A CCD COMPONENT 138 . N I 139 . F I=1:1:@CCDGLO@(0) D ; SEARCH THROUGH THE ENTIRE ARRAY 140 . . I @CCDGLO@(I)["<Body>" D ; REPLACE BODY MARKUP 141 . . . S @CCDGLO@(I)="<component><structuredBody>" ; WITH CCD EQ 142 . . I @CCDGLO@(I)["</Body>" D ; REPLACE BODY MARKUP 143 . . . S @CCDGLO@(I)="</structuredBody></component>" 144 S @CCDGLO@(3)=CAPSAVE ; UNCAP - TURN IT BACK INTO A CCD 145 S @CCDGLO@(@CCDGLO@(0))=CAPSAVE2 ; UNCAP LAST LINE 146 Q 147 ; 148 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 149 ; TAB IS PASSED BY NAME 150 W "TAB= ",TAB,! 151 ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS 152 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") 153 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") 154 I 'CCD D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 155 Q 156 ; 157 SHAVE(SHXML) ; REMOVES THE 2-6 AND N-1 AND N-2 LINES FROM A COMPONENT 158 ; NEEDED TO EXPOSE THE REPEATING PARTS FOR GENERATION 159 N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST 160 W SHXML,! 161 W @SHXML@(1),! 162 D QUEUE^C0CXPATH("SHBLD",SHXML,1,1) ; THE FIRST LINE IS NEEDED 163 D QUEUE^C0CXPATH("SHBLD",SHXML,7,@SHXML@(0)-3) ; REPEATING PART 164 D QUEUE^C0CXPATH("SHBLD",SHXML,@SHXML@(0),@SHXML@(0)) ; LAST LINE 165 D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST 166 D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION 167 D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY 168 Q 169 ; 170 UNSHAVE(ORIGXML,SHXML) ; REPLACES THE 2-6 AND N-1 AND N-2 LINES FROM TEMPLATE 171 ; NEEDED TO RESTORM FIXED TOP AND BOTTOM OF THE COMPONENT XML 172 N SHTMP,SHBLD ; TEMP ARRAY AND BUILD LIST 173 W SHXML,! 174 W @SHXML@(1),! 175 D QUEUE^C0CXPATH("SHBLD",ORIGXML,1,6) ; FIRST 6 LINES OF TEMPLATE 176 D QUEUE^C0CXPATH("SHBLD",SHXML,2,@SHXML@(0)-1) ; INS ALL BUT FIRST/LAST 177 D QUEUE^C0CXPATH("SHBLD",ORIGXML,@ORIGXML@(0)-2,@ORIGXML@(0)) ; FROM TEMP 178 D PARY^C0CXPATH("SHBLD") ; PRINT BUILD LIST 179 D BUILD^C0CXPATH("SHBLD","SHTMP") ; BUILD EDITED SECTION 180 D CP^C0CXPATH("SHTMP",SHXML) ; COPY RESULT TO PASSED ARRAY 181 Q 182 ; 183 HDRMAP(CXML,DFN,IHDR) ; MAP HEADER VARIABLES: FROM, TO ECT 184 N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) 185 ; K @VMAP 186 S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") 187 I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS 188 . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 189 . S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? 190 . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM 191 . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES 192 . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES 193 . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES 194 . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 195 I IHDR'="" D ; HEADER VALUES ARE PROVIDED 196 . D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY 197 N CTMP 198 D MAP^C0CXPATH(CXML,VMAP,"CTMP") 199 D CP^C0CXPATH("CTMP",CXML) 200 Q 201 ; 202 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 203 ; AXML AND ACTRTN ARE PASSED BY NAME 204 ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 205 ; P1= OBJECTID - ACTORPATIENT_2 206 ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE 207 ;OR INSTITUTION 208 ; OR PERSON(IN PATIENT FILE IE NOK) 209 ; P3= IEN RECORD NUMBER FOR ACTOR - 2 210 N I,J,K,L 211 K @ACTRTN ; CLEAR RETURN ARRAY 212 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 213 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR THIS LINE 214 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 215 . . W "<ActorID>=>",J,! 216 . . I J'="" S K(J)="" ; HASHING ACTOR 217 . . ; TO GET RID OF DUPLICATES 218 S I="" ; GOING TO $O THROUGH THE HASH 219 F J=0:0 D Q:$O(K(I))="" ; 220 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 221 . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID 222 . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE 223 . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR 224 . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY 225 Q 226 ; 227 TEST ; RUN ALL THE TEST CASES 228 D TESTALL^C0CUNIT("C0CCCR") 229 Q 230 ; 231 ZTEST(WHICH) ; RUN ONE SET OF TESTS 232 N ZTMP 233 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 234 D ZTEST^C0CUNIT(.ZTMP,WHICH) 235 Q 236 ; 237 TLIST ; LIST THE TESTS 238 N ZTMP 239 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 240 D TLIST^C0CUNIT(.ZTMP) 241 Q 242 ; 243 ;;><TEST> 244 ;;><PROBLEMS> 245 ;;>>>K C0C S C0C="" 246 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","","","") 247 ;;>>?@C0C@(@C0C@(0))["</Problems>" 248 ;;><VITALS> 249 ;;>>>K C0C S C0C="" 250 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","","","") 251 ;;>>?@C0C@(@C0C@(0))["</VitalSigns>" 252 ;;><CCR> 253 ;;>>>K C0C S C0C="" 254 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") 255 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 256 ;;><ACTLST> 257 ;;>>>K C0C S C0C="" 258 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","","","") 259 ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") 260 ;;><ACTORS> 261 ;;>>>D ZTEST^C0CCCR("ACTLST") 262 ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") 263 ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") 264 ;;>>?G3(G3(0))["</Actors>" 265 ;;><TRIM> 266 ;;>>>D ZTEST^C0CCCR("CCR") 267 ;;>>>W $$TRIM^C0CXPATH(CCDGLO) 268 ;;><CCD> 269 ;;>>>K C0C S C0C="" 270 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCD","","","") 271 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 272 ;;></TEST> -
ccr/trunk/p/C0CCCD1.m
r1331 r1336 1 C0CCCD1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ZT(ZARY,BAT,LINE) 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 ZLOAD(ZARY,ROUTINE) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 LOAD(ARY) 61 62 63 64 65 TRMCCD 66 67 MARKUP 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 1 C0CCCD1 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08 2 ;;1.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 ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array 26 ; ZARY IS PASSED BY NAME 27 ; BAT is a string identifying the section 28 ; LINE is a test which will evaluate to true or false 29 ; I '$G(@ZARY) D ; IF ZARY DOES NOT EXIST ' 30 ; . S @ZARY@(0)=0 ; initially there are no elements 31 ; . W "GOT HERE LOADING "_LINE,! 32 N CNT ; count of array elements 33 S CNT=@ZARY@(0) ; contains array count 34 S CNT=CNT+1 ; increment count 35 S @ZARY@(CNT)=LINE ; put the line in the array 36 ; S @ZARY@(BAT,CNT)="" ; index the test by battery 37 S @ZARY@(0)=CNT ; update the array counter 38 Q 39 ; 40 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 41 ; ZARY IS PASSED BY NAME 42 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") 43 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE 44 K @ZARY S @ZARY="" 45 S @ZARY@(0)=0 ; initialize array count 46 N LINE,LABEL,BODY 47 N INTEST S INTEST=0 ; switch for in the TEMPLATE section 48 N SECTION S SECTION="[anonymous]" ; NO section LABEL 49 ; 50 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D 51 . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section 52 . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section 53 . I INTEST D ; within the section 54 . . I LINE?." "1";><".E D ; sub-section name found 55 . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name 56 . . I LINE?." "1";;".E D ; line found 57 . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array 58 Q 59 ; 60 LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME 61 D ZLOAD(ARY,"C0CCCD1") 62 ; ZWR @ARY 63 Q 64 ; 65 TRMCCD ; ROUTINE TO BE WRITTEN TO REMOVE CCR MARKUP FROM CCD 66 Q 67 MARKUP ;<MARKUP> 68 ;;<Body> 69 ;;<Problems> 70 ;;</Problems> 71 ;;<FamilyHistory> 72 ;;</FamilyHistory> 73 ;;<SocialHistory> 74 ;;</SocialHistory> 75 ;;<Alerts> 76 ;;</Alerts> 77 ;;<Medications> 78 ;;</Medications> 79 ;;<VitalSigns> 80 ;;</VitalSigns> 81 ;;<Results> 82 ;;</Results> 83 ;;</Body> 84 ;;</ContinuityOfCareRecord> 85 ;</MARKUP> 86 ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd"> 87 ;;</ClinicalDocument> 88 Q 89 ; 90 ;<TEMPLATE> 91 ;;<?xml version="1.0"?> 92 ;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?> 93 ;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd"> 94 ;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/> 95 ;;<templateId root="2.16.840.1.113883.10.20.1"/> 96 ;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/> 97 ;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/> 98 ;;<title>Continuity of Care Document</title> 99 ;;<effectiveTime value="20000407130000+0500"/> 100 ;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/> 101 ;;<languageCode code="en-US"/> 102 ;;<recordTarget> 103 ;;<patientRole> 104 ;;<id extension="@@ACTORIEN@@" root="2.16.840.1.113883.19.5"/> 105 ;;<patient> 106 ;;<name> 107 ;;<given>@@ACTORGIVENNAME@@</given> 108 ;;<family>@@ACTORFAMILYNAME@@</family> 109 ;;<suffix>@@ACTORSUFFIXNAME@@</suffix> 110 ;;</name> 111 ;;<administrativeGenderCode code="@@ACTORGENDER@@" codeSystem="2.16.840.1.113883.5.1"/> 112 ;;<birthTime value="@@ACTORDATEOFBIRTH@@"/> 113 ;;</patient> 114 ;;<providerOrganization> 115 ;;<id root="2.16.840.1.113883.19.5"/> 116 ;;<name>@@ORGANIZATIONNAME@@</name> 117 ;;</providerOrganization> 118 ;;</patientRole> 119 ;;</recordTarget> 120 ;;<author> 121 ;;<time value="20000407130000+0500"/> 122 ;;<assignedAuthor> 123 ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/> 124 ;;<assignedPerson> 125 ;;<name> 126 ;;<prefix>@@ACTORNAMEPREFIX@@</prefix> 127 ;;<given>@@ACTORGIVENNAME@@</given> 128 ;;<family>@@ACTORFAMILYNAME@@</family> 129 ;;</name> 130 ;;</assignedPerson> 131 ;;<representedOrganization> 132 ;;<id root="2.16.840.1.113883.19.5"/> 133 ;;<name>@@ORGANIZATIONNAME@@</name> 134 ;;</representedOrganization> 135 ;;</assignedAuthor> 136 ;;</author> 137 ;;<informant> 138 ;;<assignedEntity> 139 ;;<id nullFlavor="NI"/> 140 ;;<representedOrganization> 141 ;;<id root="2.16.840.1.113883.19.5"/> 142 ;;<name>@@ORGANIZATIONNAME@@</name> 143 ;;</representedOrganization> 144 ;;</assignedEntity> 145 ;;</informant> 146 ;;<custodian> 147 ;;<assignedCustodian> 148 ;;<representedCustodianOrganization> 149 ;;<id root="2.16.840.1.113883.19.5"/> 150 ;;<name>@@ORGANIZATIONNAME@@</name> 151 ;;</representedCustodianOrganization> 152 ;;</assignedCustodian> 153 ;;</custodian> 154 ;;<legalAuthenticator> 155 ;;<time value="20000407130000+0500"/> 156 ;;<signatureCode code="S"/> 157 ;;<assignedEntity> 158 ;;<id nullFlavor="NI"/> 159 ;;<representedOrganization> 160 ;;<id root="2.16.840.1.113883.19.5"/> 161 ;;<name>@@ORGANIZATIONNAME@@</name> 162 ;;</representedOrganization> 163 ;;</assignedEntity> 164 ;;</legalAuthenticator> 165 ;;<Actors> 166 ;;<ACTOR-NOK> 167 ;;<participant typeCode="IND"> 168 ;;<associatedEntity classCode="NOK"> 169 ;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/> 170 ;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="Biiological mother"/> 171 ;;<telecom value="tel:(999)555-1212"/> 172 ;;<associatedPerson> 173 ;;<name> 174 ;;<given>Henrietta</given> 175 ;;<family>Levin</family> 176 ;;</name> 177 ;;</associatedPerson> 178 ;;</associatedEntity> 179 ;;</participant> 180 ;;</ACTOR-NOK> 181 ;;</Actors> 182 ;;<documentationOf> 183 ;;<serviceEvent classCode="PCPR"> 184 ;;<effectiveTime> 185 ;;<high value="@@DATETIME@@"/> 186 ;;</effectiveTime> 187 ;;<performer typeCode="PRF"> 188 ;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/> 189 ;;<time> 190 ;;<low value="1990"/> 191 ;;<high value='20000407'/> 192 ;;</time> 193 ;;<assignedEntity> 194 ;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/> 195 ;;<assignedPerson> 196 ;;<name> 197 ;;<prefix>@@ACTORPREFIXNAME@@</prefix> 198 ;;<given>@@ACTORGIVENNAME@@</given> 199 ;;<family>@@ACTORFAMILYNAME@@</family> 200 ;;</name> 201 ;;</assignedPerson> 202 ;;<representedOrganization> 203 ;;<id root="2.16.840.1.113883.19.5"/> 204 ;;<name>@@ORGANIZATIONNAME@@</name> 205 ;;</representedOrganization> 206 ;;</assignedEntity> 207 ;;</performer> 208 ;;</serviceEvent> 209 ;;</documentationOf> 210 ;;<Body> 211 ;;<PROBLEMS-HTML> 212 ;;<text><table border="1" width="100%"><thead><tr><th>Condition</th><th>Effective Dates</th><th>Condition Status</th></tr></thead><tbody> 213 ;;<tr><td>@@PROBLEMDESCRIPTION@@</td> 214 ;;<td>@@PROBLEMDATEOFONSET@@</td> 215 ;;<td>Active</td></tr> 216 ;;</tbody></table></text> 217 ;;</PROBLEMS-HTML> 218 ;;<Problems> 219 ;;<component> 220 ;;<section> 221 ;;<templateId root='2.16.840.1.113883.10.20.1.11'/> 222 ;;<code code="11450-4" codeSystem="2.16.840.1.113883.6.1"/> 223 ;;<title>Problems</title> 224 ;;<entry typeCode="DRIV"> 225 ;;<act classCode="ACT" moodCode="EVN"> 226 ;;<templateId root='2.16.840.1.113883.10.20.1.27'/> 227 ;;<id root="6a2fa88d-4174-4909-aece-db44b60a3abb"/> 228 ;;<code nullFlavor="NA"/> 229 ;;<entryRelationship typeCode="SUBJ"> 230 ;;<observation classCode="OBS" moodCode="EVN"> 231 ;;<templateId root='2.16.840.1.113883.10.20.1.28'/> 232 ;;<id root="d11275e7-67ae-11db-bd13-0800200c9a66"/> 233 ;;<code code="ASSERTION" codeSystem="2.16.840.1.113883.5.4"/> 234 ;;<statusCode code="completed"/> 235 ;;<effectiveTime> 236 ;;<low value="@@PROBLEMDATEOFONSET@@"/> 237 ;;</effectiveTime> 238 ;;<value xsi:type="CD" code="@@PROBLEMCODEVALUE@@" codeSystem="2.16.840.1.113883.6.96" displayName="@@PROBLEMDESCRIPTION@@"/> 239 ;;<entryRelationship typeCode="REFR"> 240 ;;<observation classCode="OBS" moodCode="EVN"> 241 ;;<templateId root='2.16.840.1.113883.10.20.1.50'/> 242 ;;<code code="33999-4" codeSystem="2.16.840.1.113883.6.1" displayName="Status"/> 243 ;;<statusCode code="completed"/> 244 ;;<value xsi:type="CE" code="55561003" codeSystem="2.16.840.1.113883.6.96" displayName="Active"/> 245 ;;</observation> 246 ;;</entryRelationship> 247 ;;</observation> 248 ;;</entryRelationship> 249 ;;</act> 250 ;;</entry> 251 ;;</section> 252 ;;</component> 253 ;;</Problems> 254 ;;<FamilyHistory> 255 ;;</FamilyHistory> 256 ;;<SocialHistory> 257 ;;</SocialHistory> 258 ;;<Alerts> 259 ;;</Alerts> 260 ;;<Medications> 261 ;;</Medications> 262 ;;<VitalSigns> 263 ;;</VitalSigns> 264 ;;<Results> 265 ;;</Results> 266 ;;</Body> 267 ;;</ClinicalDocument> 268 ;</TEMPLATE> -
ccr/trunk/p/C0CCCR.m
r1331 r1336 1 C0CCCR 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 EXPORT 24 25 26 27 28 29 30 31 XPAT(DFN,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 61 DCCR(DFN) 62 63 64 65 66 67 68 69 70 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) 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 INITSTPS(TAB) 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 HDRMAP(CXML,DFN) 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 ACTLST(AXML,ACTRTN) 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 TEST 234 235 236 237 ZTEST(WHICH) 238 239 240 241 242 243 TLIST 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 1 C0CCCR ; CCDCCR/GPL - CCR MAIN PROCESSING; 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 ; EXPORT A CCR 22 ; 23 EXPORT ; EXPORT ENTRY POINT FOR CCR 24 ; Select a patient. 25 S DIC=2,DIC(0)="AEMQ" D ^DIC 26 I Y<1 Q ; EXIT 27 S DFN=$P(Y,U,1) ; SET THE PATIENT 28 D XPAT(DFN) ; EXPORT TO A FILE 29 Q 30 ; 31 XPAT(DFN,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 DCCR(DFN) ; DISPLAY A CCR THAT HAS JUST BEEN EXTRACTED 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 CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT 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 D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") 106 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! 107 ; 108 D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES 109 ; 110 K ^TMP("C0CCCR",$J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT 111 S CCRXTAB=$NA(^TMP("C0CCCR",$J,"CCRSTEP")) ; GLOBAL TO STORE CCR STEPS 112 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS 113 N PROCI,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD 114 F PROCI=1:1:@CCRXTAB@(0) D ; PROCESS THE CCR BODY SECTIONS 115 . S XI=@CCRXTAB@(PROCI) ; CALL COPONENTS TO PARSE 116 . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL 117 . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL 118 . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE 119 . D QUERY^C0CXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS 120 . S IXML="INXML" 121 . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES 122 . ; K @OXML ; KILL EXPECTED OUTPUT ARRAY 123 . ; W OXML,! 124 . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL 125 . W "RUNNING ",CALL,! 126 . X CALL 127 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 128 . I $G(@OXML@(0))>0 D ; THERE IS A RESULT 129 . . D INSERT^C0CXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") 130 . . I DEBUG F C0CI=1:1:@OXML@(0) W @OXML@(C0CI),! 131 N ACTT,ATMP,ACTT2,ATMP2 ; TEMPORARY ARRAY SYMBOLS FOR ACTOR PROCESSING 132 D ACTLST^C0CCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST 133 D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","ACTT") 134 D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") 135 D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") 136 K ACTT,ACTT2 137 ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") 138 ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") 139 ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") 140 ; gpl - turned off Comments for Certification 141 K CMTT,CMTT2 142 N TRIMI,J,DONE S DONE=0 143 F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE 144 . S J=$$TRIM^C0CXPATH(CCRGLO) ; DELETE EMPTY ELEMENTS 145 . I DEBUG W "TRIMMED",J,! 146 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE 147 ;S CCRGRTN=$NA(^TMP("C0CCCR",$J,DFN,CCRPART)) ; RTN GLOBAL OF PART OR ALL 148 I CCRPART="CCR" M CCRGRTN=@CCRGLO ; ENTIRE CCR 149 E M CCRGRTN=^TMP("C0CCCR",$J,DFN,CCRPART) ; RTN GLOBAL OF PART 150 I '$D(C0CNRPC) S ^TMP("C0CRPC",$H,"RESULT",CCRGRTN(0))="" 151 K ^TMP("C0CCCR",$J) ; BEGIN TO CLEAN UP 152 K ^TMP($J) ; REALLY CLEAN UP 153 M ^TMP($J)=^TMP("C0CSAV",$J) ; RESTORE CALLER'S $J 154 Q 155 ; 156 INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS 157 ; TAB IS PASSED BY NAME 158 I DEBUG W "TAB= ",TAB,! 159 ; ORDER FOR CCR IS PROBLEMS,FAMILYHISTORY,SOCIALHISTORY,MEDICATIONS,VITALSIGNS,RESULTS,HEALTHCAREPROVIDERS 160 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP(""C0CCCR"",$J,DFN,""PROBLEMS"")") 161 I TESTALERT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CALERT;//ContinuityOfCareRecord/Body/Alerts;^TMP(""C0CCCR"",$J,DFN,""ALERTS"")") 162 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CMED;//ContinuityOfCareRecord/Body/Medications;^TMP(""C0CCCR"",$J,DFN,""MEDICATIONS"")") 163 D PUSH^C0CXPATH(TAB,"MAP;C0CIMMU;//ContinuityOfCareRecord/Body/Immunizations;^TMP(""C0CCCR"",$J,DFN,""IMMUNE"")") 164 I TESTVIT D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVIT2;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 165 E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") 166 D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") 167 D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") 168 ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") 169 ; gpl - turned off Encounters for Certification 170 Q 171 ; 172 HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT 173 N VMAP S VMAP=$NA(^TMP("C0CCCR",$J,DFN,"HEADER")) 174 ; K @VMAP 175 S @VMAP@("DATETIME")=$$FMDTOUTC^C0CUTIL($$NOW^XLFDT,"DT") 176 ; I IHDR="" D ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS 177 D ; ALWAYS MAP THESE VARIABLES 178 . S @VMAP@("CCRDOCOBJECTID")=$$UUID^C0CUTIL ; UUID FOR THIS CCR 179 . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 180 . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - FROM PROVIDER 181 . ;S @VMAP@("ACTORFROM")="ACTORORGANIZATION_"_DUZ ; FROM DUZ - ??? 182 . S @VMAP@("ACTORFROM2")="ACTORSYSTEM_1" ; SECOND FROM IS THE SYSTEM 183 . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES 184 . S @VMAP@("PURPOSEDESCRIPTION")="CEND PHR" ; FOR TEST PURPOSES 185 . S @VMAP@("ACTORTOTEXT")="Patient" ; FOR TEST PURPOSES 186 . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 187 ;I IHDR'="" D ; HEADER VALUES ARE PROVIDED 188 ;. D CP^C0CXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY 189 N CTMP 190 D MAP^C0CXPATH(CXML,VMAP,"CTMP") 191 D CP^C0CXPATH("CTMP",CXML) 192 N HRIMVARS ; 193 S HRIMVARS=$NA(^TMP("C0CRIM","VARS",DFN,"HEADER")) ; TO PERSIST VARS 194 M @HRIMVARS@(1)=@VMAP ; PERSIST THE HEADER VARIABLES IN RIM TABLE 195 S @HRIMVARS@(0)=1 ; ONLY ONE SET OF HEADERS PER PATIENT 196 Q 197 ; 198 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 199 ; AXML AND ACTRTN ARE PASSED BY NAME 200 ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2 201 ; P1= OBJECTID - ACTORPATIENT_2 202 ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE 203 ;OR INSTITUTION 204 ; OR PERSON(IN PATIENT FILE IE NOK) 205 ; P3= IEN RECORD NUMBER FOR ACTOR - 2 206 N I,J,K,L 207 K @ACTRTN ; CLEAR RETURN ARRAY 208 F I=1:1:@AXML@(0) D ; FIRST FIX MISSING LINKS 209 . I @AXML@(I)?.E1"_<".E D ; 210 . . N ZA,ZB 211 . . S ZA=$P(@AXML@(I),">",1)_">" 212 . . S ZB="<"_$P(@AXML@(I),"<",3) 213 . . S @AXML@(I)=ZA_"ACTORORGANIZATION_1"_ZB 214 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 215 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR THIS LINE 216 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 217 . . I $G(LINKDEBUG) W "<ActorID>=>",J,! 218 . . I J'="" S K(J)="" ; HASHING ACTOR 219 . I @AXML@(I)?.E1"<LinkID>".E D ; THERE IS AN ACTOR THIS LINE 220 . . S J=$P($P(@AXML@(I),"<LinkID>",2),"</LinkID>",1) 221 . . I $G(LINKDEBUG) W "<LinkID>=>",J,! 222 . . I J'="" S K(J)="" ; HASHING ACTOR 223 . . ; TO GET RID OF DUPLICATES 224 S I="" ; GOING TO $O THROUGH THE HASH 225 F J=0:0 D Q:$O(K(I))="" 226 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 227 . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID 228 . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE 229 . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR 230 . D PUSH^C0CXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY 231 Q 232 ; 233 TEST ; RUN ALL THE TEST CASES 234 D TESTALL^C0CUNIT("C0CCCR") 235 Q 236 ; 237 ZTEST(WHICH) ; RUN ONE SET OF TESTS 238 N ZTMP 239 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 240 D ZTEST^C0CUNIT(.ZTMP,WHICH) 241 Q 242 ; 243 TLIST ; LIST THE TESTS 244 N ZTMP 245 D ZLOAD^C0CUNIT("ZTMP","C0CCCR") 246 D TLIST^C0CUNIT(.ZTMP) 247 Q 248 ; 249 ;;><TEST> 250 ;;><PROBLEMS> 251 ;;>>>K C0C S C0C="" 252 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","PROBLEMS","") 253 ;;>>?@C0C@(@C0C@(0))["</Problems>" 254 ;;><VITALS> 255 ;;>>>K C0C S C0C="" 256 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","VITALS","") 257 ;;>>?@C0C@(@C0C@(0))["</VitalSigns>" 258 ;;><CCR> 259 ;;>>>K C0C S C0C="" 260 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 261 ;;>>?@C0C@(@C0C@(0))["</ContinuityOfCareRecord>" 262 ;;><ACTLST> 263 ;;>>>K C0C S C0C="" 264 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","CCR","") 265 ;;>>>D ACTLST^C0CCCR(C0C,"ACTTEST") 266 ;;><ACTORS> 267 ;;>>>D ZTEST^C0CCCR("ACTLST") 268 ;;>>>D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Actors","G2") 269 ;;>>>D EXTRACT^C0CACTOR("G2","ACTTEST","G3") 270 ;;>>?G3(G3(0))["</Actors>" 271 ;;><TRIM> 272 ;;>>>D ZTEST^C0CCCR("CCR") 273 ;;>>>W $$TRIM^C0CXPATH(CCRGLO) 274 ;;><ALERTS> 275 ;;>>>S TESTALERT=1 276 ;;>>>K C0C S C0C="" 277 ;;>>>D CCRRPC^C0CCCR(.C0C,"2","ALERTS","") 278 ;;>>?@C0C@(@C0C@(0))["</Alerts>" 279 280 -
ccr/trunk/p/C0CCCR0.m
r1331 r1336 1 C0CCCR0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ZT(ZARY,BAT,LINE) 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 ZLOAD(ZARY,ROUTINE) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 LOAD(ARY) 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 1 C0CCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08 2 ;;1.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 ;;<Specialty> 795 ;;<Text>@@ACTORSPECIALITY@@</Text> 796 ;;</Specialty> 797 ;;<Address> 798 ;;<Type> 799 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 800 ;;</Type> 801 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 802 ;;<City>@@ACTORADDRESSCITY@@</City> 803 ;;<State>@@ACTORADDRESSSTATE@@</State> 804 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 805 ;;</Address> 806 ;;<Telephone> 807 ;;<Value>@@ACTORTELEPHONE@@</Value> 808 ;;<Type> 809 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 810 ;;</Type> 811 ;;</Telephone> 812 ;;<Email> 813 ;;<Value>@@ACTOREMAIL@@</Value> 814 ;;</Email> 815 ;;<Source> 816 ;;<Actor> 817 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 818 ;;</Actor> 819 ;;</Source> 820 ;;<InternalCCRLink> 821 ;;<LinkID>@@ACTORORGLINK@@</LinkID> 822 ;;<LinkRelationship>representedOrganization</LinkRelationship> 823 ;;</InternalCCRLink> 824 ;;</Actor> 825 ;;</ACTOR-PROVIDER> 826 ;;<ACTOR-ORG> 827 ;;<Actor> 828 ;;<ActorObjectID>@@ACTOROBJECTID@@</ActorObjectID> 829 ;;<Organization> 830 ;;<Name>@@ORGANIZATIONNAME@@</Name> 831 ;;</Organization> 832 ;;<Address> 833 ;;<Type> 834 ;;<Text>@@ACTORADDRESSTYPE@@</Text> 835 ;;</Type> 836 ;;<Line1>@@ACTORADDRESSLINE1@@</Line1> 837 ;;<City>@@ACTORADDRESSCITY@@</City> 838 ;;<State>@@ACTORADDRESSSTATE@@</State> 839 ;;<PostalCode>@@ACTORPOSTALCODE@@</PostalCode> 840 ;;</Address> 841 ;;<Telephone> 842 ;;<Value>@@ACTORTELEPHONE@@</Value> 843 ;;<Type> 844 ;;<Text>@@ACTORTELEPHONETYPE@@</Text> 845 ;;</Type> 846 ;;</Telephone> 847 ;;<Source> 848 ;;<Actor> 849 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 850 ;;</Actor> 851 ;;</Source> 852 ;;</Actor> 853 ;;</ACTOR-ORG> 854 ;;</Actors> 855 ;;<Signatures> 856 ;;<CCRSignature> 857 ;;<SignatureObjectID>S0001</SignatureObjectID> 858 ;;<ExactDateTime>2008-03-18T23:10:58Z</ExactDateTime> 859 ;;<Source> 860 ;;<ActorID>AA0001</ActorID> 861 ;;</Source> 862 ;;<Signature> 863 ;;<Signature xmlns="http://www.w3.org/2000/09/xmldsig#"> 864 ;;<SignedInfo> 865 ;;<CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315"/> 866 ;;<SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#rsa-sha1"/> 867 ;;<Reference URI=""> 868 ;;<Transforms> 869 ;;<Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature"/> 870 ;;</Transforms> 871 ;;<DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1"/> 872 ;;<DigestValue>YFveLLyo+75P7rSciv0/m1O6Ot4=</DigestValue> 873 ;;</Reference> 874 ;;</SignedInfo> 875 ;;<SignatureValue>Bj6sACXl74hrlbUYnu8HqnRab5VGy69BOYjOH7dETxgppXMEd7AoVYaePZvgJft78JR4oQY76hbFyGcIslYauPpJxx2hCd5d56xFeaQg01R6AQOvGnhjlq63TbpFdUq0B4tYsmiibJPbQJhTQe+TcWTBvWaQt8Fkk5blO571YvI=</SignatureValue> 876 ;;<KeyInfo> 877 ;;<KeyValue> 878 ;;<RSAKeyValue> 879 ;;<Modulus>meH817QYol+/uUEg6j8Mg89s7GTlaN9B+/CGlzrtnQH+swMigZRnEPxHVO8PhEymP/W9nlhAjTScV/CUzA9yJ9WiaOn17c+KReKhfBqL24DX9BpbJ+kLYVz7mBO5Qydk5AzUT2hFwW93irD8iRKP+/t+2Mi2CjNfj8VTjJpHpm0=</Modulus> 880 ;;<Exponent>AQAB</Exponent> 881 ;;</RSAKeyValue> 882 ;;</KeyValue> 883 ;;</KeyInfo> 884 ;;</Signature> 885 ;;</Signature> 886 ;;</CCRSignature> 887 ;;</Signatures> 888 ;;<Comments> 889 ;;<Comment> 890 ;;<CommentObjectID>@@COMMENTOBJECTID@@</CommentObjectID> 891 ;;<DateTime> 892 ;;<ExactDateTime>@@CMTDATETIME@@</ExactDateTime> 893 ;;</DateTime> 894 ;;<Description> 895 ;;<Text> 896 ;;</Text> 897 ;;</Description> 898 ;;<Source> 899 ;;<Actor> 900 ;;<ActorID>@@ACTORSOURCEID@@</ActorID> 901 ;;</Actor> 902 ;;</Source> 903 ;;</Comment> 904 ;;</Comments> 905 ;;</ContinuityOfCareRecord> 906 ;</TEMPLATE> -
ccr/trunk/p/C0CCMT.m
r1331 r1336 1 C0CCMT 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(NOTEXML,DFN,NOTEOUT) 25 26 27 28 29 30 31 32 MAP(NOTEXML,C0CNTE,NOTEOUT) 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 CLEAN(INARY) 60 61 62 63 64 65 66 1 C0CCMT ; CCDCCR/GPL - CCR/CCD PROCESSING FOR COMMENTS ; 05/21/10 2 ;;1.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
r1331 r1336 1 C0CCPT 2 3 4 5 ENTRY(DFN,STDT,ENDDT,TXT) 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 VISIT 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 GETNOTE(IEN) 86 87 88 89 90 91 1 C0CCPT ;;BSL;RETURN CPT DATA; 2 ;Sequence Managers Software GPL;;;;;Build 38 3 ;Copied into C0C namespace from SQMCPT with permission from 4 ;Brian Lord - and with our thanks. gpl 01/20/2010 5 ENTRY(DFN,STDT,ENDDT,TXT) ;BUILD TOTAL ARRAY OF ALL IEN'S FOR TIU NOTES 6 ;DFN=PATIENT IEN 7 ;STDT=START DATE IN 3100101 FORMAT (VA YEAR YYYMMDD) 8 ;ENDDT=END DATE IN 3100101 FORMAT 9 ;TXT=INCLUDE TEXT FROM ENCOUNTER NOTE 10 ;THAT FALL INSIDE DATA RANGE. IF NO STDT OR ENDDT ASSUME 11 ;ALL INCLUSIVE IN THAT DIRECTION 12 ;LIST OF TIU DOCS IN ^TIU(8925,"ACLPT",3,DFN) 13 ;BUILD INTO NOTE(Y)="" 14 S U="^",X="" 15 F S X=$O(^TIU(8925,"ACLPT",3,DFN,X)) Q:X="" D 16 . S Y="" 17 . F S Y=$O(^TIU(8925,"ACLPT",3,DFN,X,Y)) Q:Y="" D 18 .. S NOTE(Y)="" 19 ;NOW DELETE ANY NOTES THAT DON'T FALL INTO DATE RANGE 20 ;GET DATE OF NOTE 21 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 D VISIT 30 Q 31 VISIT ;GET VISIT INFO FOR A GIVEN NOTE. BUILD INTO RETURN ARRAY .VISIT 32 S ILST=1,X0="",X12="",VISIT="",LST="",X811="" 33 S IEN="" F S IEN=$O(NOTE(IEN)) Q:IEN="" D 34 . S X0=^TIU(8925,IEN,0),X12=$G(^(12)) 35 . S VISIT=$P(X12,U,7) 36 . I 'VISIT S VISIT=$P(X0,U,3) 37 . K ^TMP("PXKENC",$J) 38 . Q:VISIT=""!(VISIT'>0) 39 . D ENCEVENT^PXKENC(VISIT,1) 40 . I '$D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0)) Q 41 . S IPRV=0 F S IPRV=$O(^TMP("PXKENC",$J,VISIT,"PRV",IPRV)) Q:'IPRV D 42 .. S X0=^TMP("PXKENC",$J,VISIT,"PRV",IPRV,0) 43 .. ;Q:$P(X0,U,4)'="P" 44 .. S CODE=$P(X0,U),NARR=$P($G(^VA(200,CODE,0)),U) 45 .. S PRIM=($P(X0,U,4)="P") 46 .. S ILST=ILST+1 47 .. S LST(ILST)="PRV"_U_CODE_"^^^"_NARR_"^"_PRIM 48 .. S VISIT(IEN,"PRV",ILST)=CODE_"^^^"_NARR_"^"_PRIM 49 . S IPOV=0 F S IPOV=$O(^TMP("PXKENC",$J,VISIT,"POV",IPOV)) Q:'IPOV D 50 .. S X0=^TMP("PXKENC",$J,VISIT,"POV",IPOV,0),X802=$G(^(802)),X811=$G(^(811)) 51 .. S CODE=$P(X0,U) 52 .. S:CODE CODE=$P(^ICD9(CODE,0),U) 53 .. S CAT=$P(X802,U) 54 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 55 .. S NARR=$P(X0,U,4) 56 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 57 .. S PRIM=($P(X0,U,12)="P") 58 .. S PRV=$P(X12,U,4) 59 .. S ILST=ILST+1 60 .. S LST(ILST)="POV"_U_CODE_U_CAT_U_NARR_U_PRIM_U_PRV 61 .. S VISIT(IEN,"POV",ILST)=CODE_U_CAT_U_NARR_U_PRIM_U_PRV 62 . S ICPT=0 F S ICPT=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT)) Q:'ICPT D 63 .. S X0=^TMP("PXKENC",$J,VISIT,"CPT",ICPT,0),X802=$G(^(802)),X12=$G(^(12)),X811=$G(^(811)) 64 .. ;S CODE=$P(X0,U) 65 .. S CODE=$O(^ICPT("B",$P(X0,U),0)) 66 .. S:CODE CODE=$P(^ICPT(CODE,0),U) 67 .. S CAT=$P(X802,U) 68 .. S:CAT CAT=$P(^AUTNPOV(CAT,0),U) 69 .. S NARR=$P(X0,U,4) 70 .. S:NARR NARR=$P(^AUTNPOV(NARR,0),U) 71 .. S QTY=$P(X0,U,16) 72 .. S PRV=$P(X12,U,4) 73 .. S MCNT=0,MIDX=0,MODS="" 74 .. F S MIDX=$O(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX)) Q:'MIDX D 75 ... S MIEN=$G(^TMP("PXKENC",$J,VISIT,"CPT",ICPT,1,MIDX,0)) 76 ... I +MIEN S MCNT=MCNT+1,MODS=MODS_";/"_MIEN 77 .. I +MCNT S MODS=MCNT_MODS 78 .. S ILST=ILST+1 79 .. S LST(ILST)="CPT"_U_CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 80 .. S VISIT(IEN,"CPT",ILST)=CODE_U_CAT_U_NARR_U_QTY_U_PRV_U_U_U_MODS 81 . S VISIT(IEN,"DATE",0)=$P($P(^TIU(8925,IEN,0),U,7),".") 82 . S VISIT(IEN,"CLASS")=$$GET1^DIQ(8925,IEN_",",.04) ;GPL 5/21/10 83 . I $G(TXT)=1 D GETNOTE(IEN) 84 Q 85 GETNOTE(IEN) ;GET THE TEXT THAT GOES WITH VISIT 86 ;EXTRACT NOTE TEXT FROM ^TIU(8925,IEN,"TEXT" 87 Q:'$D(VISIT(IEN,"CPT")) 88 S TXTCNT=0 89 F S TXTCNT=TXTCNT+1 Q:'$D(^TIU(8925,IEN,"TEXT",TXTCNT,0)) D 90 . S VISIT(IEN,"TEXT",TXTCNT)=^TIU(8925,IEN,"TEXT",TXTCNT,0) 91 Q -
ccr/trunk/p/C0CDOM.m
r1204 r1336 1 C0CDOM 1 C0CDOM ; GPL - DOM PROCESSING ROUTINES ;6/6/11 17:05 2 2 ;;0.1;C0C;nopatch;noreleasedate;Build 38 3 3 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU … … 20 20 Q 21 21 ; 22 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) 22 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 23 23 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 24 24 ; THE XPATH ARRAY XPARY, PASSED BY NAME … … 82 82 Q 83 83 ; 84 PARSE(INXML,INDOC) 84 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 85 85 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 86 86 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML … … 88 88 Q $$EN^MXMLDOM(INXML,"W") 89 89 ; 90 ISMULT(ZOID) 90 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 91 91 N ZN 92 92 ;I $$TAG(ZOID)["entry" B … … 95 95 Q 0 96 96 ; 97 FIRST(ZOID) 97 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 98 98 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 99 99 ; 100 PARENT(ZOID) 100 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 101 101 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 102 102 ; 103 ATT(RTN,NODE) 103 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 104 104 S HANDLE=C0CDOCID 105 105 K @RTN … … 107 107 Q 108 108 ; 109 TAG(ZOID) 109 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 110 110 ;I ZOID=149 B ;GPLTEST 111 111 N X,Y … … 116 116 Q Y 117 117 ; 118 NXTSIB(ZOID) 118 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 119 119 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 120 120 ; 121 DATA(ZT,ZOID) 121 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 122 122 ;N ZT,ZN S ZT="" 123 123 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) … … 126 126 Q 127 127 ; 128 OUTXML(ZRTN,INID,NO1ST) 128 OUTXML(ZRTN,INID,NO1ST) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 129 129 ; 130 130 S C0CDOCID=INID … … 137 137 Q 138 138 ; 139 NDOUT(ZOID) 139 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 140 140 N ZI S ZI=$$FIRST(ZOID) 141 141 I ZI'=0 D ; THERE IS A CHILD -
ccr/trunk/p/C0CDPT.m
r1331 r1336 1 C0CDPT 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 FAMILY(DFN) 90 91 92 93 GIVEN(DFN) 94 95 96 97 MIDDLE(DFN) 98 99 100 101 SUFFIX(DFN) 102 103 104 105 DISPNAME(DFN) 106 107 108 109 DOB(DFN) 110 111 112 113 GENDER(DFN) 114 115 SSN(DFN) 116 117 ADDRTYPE(DFN) 118 119 120 ADDR1(DFN) 121 122 ADDR2(DFN) 123 124 125 126 127 128 CITY(DFN) 129 130 STATE(DFN) 131 132 ZIP(DFN) 133 134 COUNTY(DFN) 135 136 COUNTRY(DFN) 137 138 139 RESTEL(DFN) 140 141 WORKTEL(DFN) 142 143 EMAIL(DFN) 144 145 CELLTEL(DFN) 146 147 NOK1FAM(DFN) 148 149 150 151 NOK1GIV(DFN) 152 153 154 155 NOK1MID(DFN) 156 157 158 159 NOK1SUF(DFN) 160 161 162 163 NOK1DISP(DFN) 164 165 166 167 NOK1REL(DFN) 168 169 NOK1ADD1(DFN) 170 171 NOK1ADD2(DFN) 172 173 174 175 176 NOK1CITY(DFN) 177 178 NOK1STAT(DFN) 179 180 NOK1ZIP(DFN) 181 182 NOK1HTEL(DFN) 183 184 NOK1WTEL(DFN) 185 186 NOK1SAME(DFN) 187 188 NOK2FAM(DFN) 189 190 191 192 NOK2GIV(DFN) 193 194 195 196 NOK2MID(DFN) 197 198 199 200 NOK2SUF(DFN) 201 202 203 204 NOK2DISP(DFN) 205 206 207 208 NOK2REL(DFN) 209 210 NOK2ADD1(DFN) 211 212 NOK2ADD2(DFN) 213 214 215 216 217 NOK2CITY(DFN) 218 219 NOK2STAT(DFN) 220 221 NOK2ZIP(DFN) 222 223 NOK2HTEL(DFN) 224 225 NOK2WTEL(DFN) 226 227 NOK2SAME(DFN) 228 229 EMERFAM(DFN) 230 231 232 233 EMERGIV(DFN) 234 235 236 237 EMERMID(DFN) 238 239 240 241 EMERSUF(DFN) 242 243 244 245 EMERDISP(DFN) 246 247 248 249 EMERREL(DFN) 250 251 EMERADD1(DFN) 252 253 EMERADD2(DFN) 254 255 256 257 258 EMERCITY(DFN) 259 260 EMERSTAT(DFN) 261 262 EMERZIP(DFN) 263 264 EMERHTEL(DFN) 265 266 EMERWTEL(DFN) 267 268 EMERSAME(DFN) 269 1 C0CDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;1.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 FAMILY(DFN) ; Family Name 90 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 91 D NAMECOMP^XLFNAME(.NAME) 92 Q NAME("FAMILY") 93 GIVEN(DFN) ; Given Name 94 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 95 D NAMECOMP^XLFNAME(.NAME) 96 Q NAME("GIVEN") 97 MIDDLE(DFN) ; Middle Name 98 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 99 D NAMECOMP^XLFNAME(.NAME) 100 Q NAME("MIDDLE") 101 SUFFIX(DFN) ; Suffi Name 102 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 103 D NAMECOMP^XLFNAME(.NAME) 104 Q NAME("SUFFIX") 105 DISPNAME(DFN) ; Display Name 106 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 107 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 108 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 109 DOB(DFN) ; Date of Birth 110 N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") 111 ; Date in FM Date Format. Convert to UTC/ISO 8601. 112 Q $$FMDTOUTC^C0CUTIL(DOB,"D") 113 GENDER(DFN) ; Gender/Sex 114 Q $$GET1^DIQ(2,DFN,.02,"I")_"^"_$$GET1^DIQ(2,DFN,.02,"E") ; 115 SSN(DFN) ; SSN 116 Q $$GET1^DIQ(2,DFN,.09) 117 ADDRTYPE(DFN) ; Address Type 118 ; Vista only stores a home address for the patient. 119 Q "Home" 120 ADDR1(DFN) ; Get Home Address line 1 121 Q $$GET1^DIQ(2,DFN,.111) 122 ADDR2(DFN) ; Get Home Address line 2 123 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise 124 N ADDLN2,ADDLN3 125 S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) 126 Q:ADDLN3="" ADDLN2 127 Q ADDLN2_", "_ADDLN3 128 CITY(DFN) ; Get City for Home Address 129 Q $$GET1^DIQ(2,DFN,.114) 130 STATE(DFN) ; Get State for Home Address 131 Q $$GET1^DIQ(2,DFN,.115) 132 ZIP(DFN) ; Get Zip code for Home Address 133 Q $$GET1^DIQ(2,DFN,.116) 134 COUNTY(DFN) ; Get County for our Address 135 Q $$GET1^DIQ(2,DFN,.117) 136 COUNTRY(DFN) ; Get Country for our Address 137 ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... 138 Q "USA" 139 RESTEL(DFN) ; Residential Telephone 140 Q $$GET1^DIQ(2,DFN,.131) 141 WORKTEL(DFN) ; Work Telephone 142 Q $$GET1^DIQ(2,DFN,.132) 143 EMAIL(DFN) ; Email Adddress 144 Q $$GET1^DIQ(2,DFN,.133) 145 CELLTEL(DFN) ; Cell Phone 146 Q $$GET1^DIQ(2,DFN,.134) 147 NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name 148 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 149 D NAMECOMP^XLFNAME(.NAME) 150 Q NAME("FAMILY") 151 NOK1GIV(DFN) ; NOK1 Given Name 152 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 153 D NAMECOMP^XLFNAME(.NAME) 154 Q NAME("GIVEN") 155 NOK1MID(DFN) ; NOK1 Middle Name 156 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 157 D NAMECOMP^XLFNAME(.NAME) 158 Q NAME("MIDDLE") 159 NOK1SUF(DFN) ; NOK1 Suffi Name 160 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 161 D NAMECOMP^XLFNAME(.NAME) 162 Q NAME("SUFFIX") 163 NOK1DISP(DFN) ; NOK1 Display Name 164 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 165 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 166 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 167 NOK1REL(DFN) ; NOK1 Relationship to the patient 168 Q $$GET1^DIQ(2,DFN,.212) 169 NOK1ADD1(DFN) ; NOK1 Address 1 170 Q $$GET1^DIQ(2,DFN,.213) 171 NOK1ADD2(DFN) ; NOK1 Address 2 172 N ADDLN2,ADDLN3 173 S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) 174 Q:ADDLN3="" ADDLN2 175 Q ADDLN2_", "_ADDLN3 176 NOK1CITY(DFN) ; NOK1 City 177 Q $$GET1^DIQ(2,DFN,.216) 178 NOK1STAT(DFN) ; NOK1 State 179 Q $$GET1^DIQ(2,DFN,.217) 180 NOK1ZIP(DFN) ; NOK1 Zip Code 181 Q $$GET1^DIQ(2,DFN,.218) 182 NOK1HTEL(DFN) ; NOK1 Home Telephone 183 Q $$GET1^DIQ(2,DFN,.219) 184 NOK1WTEL(DFN) ; NOK1 Work Telephone 185 Q $$GET1^DIQ(2,DFN,.21011) 186 NOK1SAME(DFN) ; Is NOK1's Address the same the patient? 187 Q $$GET1^DIQ(2,DFN,.2125) 188 NOK2FAM(DFN) ; NOK2 Family Name 189 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 190 D NAMECOMP^XLFNAME(.NAME) 191 Q NAME("FAMILY") 192 NOK2GIV(DFN) ; NOK2 Given Name 193 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 194 D NAMECOMP^XLFNAME(.NAME) 195 Q NAME("GIVEN") 196 NOK2MID(DFN) ; NOK2 Middle Name 197 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 198 D NAMECOMP^XLFNAME(.NAME) 199 Q NAME("MIDDLE") 200 NOK2SUF(DFN) ; NOK2 Suffi Name 201 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 202 D NAMECOMP^XLFNAME(.NAME) 203 Q NAME("SUFFIX") 204 NOK2DISP(DFN) ; NOK2 Display Name 205 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 206 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 207 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 208 NOK2REL(DFN) ; NOK2 Relationship to the patient 209 Q $$GET1^DIQ(2,DFN,.2192) 210 NOK2ADD1(DFN) ; NOK2 Address 1 211 Q $$GET1^DIQ(2,DFN,.2193) 212 NOK2ADD2(DFN) ; NOK2 Address 2 213 N ADDLN2,ADDLN3 214 S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) 215 Q:ADDLN3="" ADDLN2 216 Q ADDLN2_", "_ADDLN3 217 NOK2CITY(DFN) ; NOK2 City 218 Q $$GET1^DIQ(2,DFN,.2196) 219 NOK2STAT(DFN) ; NOK2 State 220 Q $$GET1^DIQ(2,DFN,.2197) 221 NOK2ZIP(DFN) ; NOK2 Zip Code 222 Q $$GET1^DIQ(2,DFN,.2198) 223 NOK2HTEL(DFN) ; NOK2 Home Telephone 224 Q $$GET1^DIQ(2,DFN,.2199) 225 NOK2WTEL(DFN) ; NOK2 Work Telephone 226 Q $$GET1^DIQ(2,DFN,.211011) 227 NOK2SAME(DFN) ; Is NOK2's Address the same the patient? 228 Q $$GET1^DIQ(2,DFN,.21925) 229 EMERFAM(DFN) ; Emergency Contact (EMER) Family Name 230 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 231 D NAMECOMP^XLFNAME(.NAME) 232 Q NAME("FAMILY") 233 EMERGIV(DFN) ; EMER Given Name 234 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 235 D NAMECOMP^XLFNAME(.NAME) 236 Q NAME("GIVEN") 237 EMERMID(DFN) ; EMER Middle Name 238 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 239 D NAMECOMP^XLFNAME(.NAME) 240 Q NAME("MIDDLE") 241 EMERSUF(DFN) ; EMER Suffi Name 242 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 243 D NAMECOMP^XLFNAME(.NAME) 244 Q NAME("SUFFIX") 245 EMERDISP(DFN) ; EMER Display Name 246 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 247 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 248 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 249 EMERREL(DFN) ; EMER Relationship to the patient 250 Q $$GET1^DIQ(2,DFN,.331) 251 EMERADD1(DFN) ; EMER Address 1 252 Q $$GET1^DIQ(2,DFN,.333) 253 EMERADD2(DFN) ; EMER Address 2 254 N ADDLN2,ADDLN3 255 S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) 256 Q:ADDLN3="" ADDLN2 257 Q ADDLN2_", "_ADDLN3 258 EMERCITY(DFN) ; EMER City 259 Q $$GET1^DIQ(2,DFN,.336) 260 EMERSTAT(DFN) ; EMER State 261 Q $$GET1^DIQ(2,DFN,.337) 262 EMERZIP(DFN) ; EMER Zip Code 263 Q $$GET1^DIQ(2,DFN,.338) 264 EMERHTEL(DFN) ; EMER Home Telephone 265 Q $$GET1^DIQ(2,DFN,.339) 266 EMERWTEL(DFN) ; EMER Work Telephone 267 Q $$GET1^DIQ(2,DFN,.33011) 268 EMERSAME(DFN) ; Is EMER's Address the same the NOK? 269 Q $$GET1^DIQ(2,DFN,.3305) -
ccr/trunk/p/C0CENC.m
r1331 r1336 1 C0CENC 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(ENCXML,DFN,ENCOUT) 25 26 27 28 29 30 31 32 33 34 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 GETTYPE(ZARY,ZTXT,ZCDE,ZSYS) 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 ANYTXT(ZVST) 130 131 132 133 134 135 136 137 138 139 140 141 142 143 PRV(IARY) 144 145 146 147 148 149 150 151 DATE(ISTR) 152 153 154 CPT(ISTR) 155 156 157 158 159 160 161 162 163 164 165 166 167 168 MAP(ENCXML,C0CENC,ENCOUT) 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 1 C0CENC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ENCOUNTERS ; 05/21/10 2 ;;1.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/C0CENV.m
r1267 r1336 22 22 ; 23 23 CHECK ; Perform environment check 24 24 ; 25 25 I $S('$G(IOM):1,'$G(IOSL):1,$G(U)'="^":1,1:0) D 26 26 . D BMES("Terminal Device is not defined") … … 34 34 . D BMES("You are not a valid user on this system") 35 35 . S XPDQUIT=2 36 37 38 36 Q 37 ; 38 ; 39 39 EXIT ; 40 41 40 ; 41 ; 42 42 I $G(XPDQUIT) D BMES("--- Install Environment Check FAILED ---") Q 43 43 D BMES("--- Environment Check is Ok ---") 44 44 ; 45 45 Q 46 47 46 ; 47 ; 48 48 PRE ;Pre-install entry point 49 50 51 52 53 54 55 49 ; 50 ; No action needed in pre-install 51 D BMES("No action need for pre-install") 52 ; 53 Q 54 ; 55 ; 56 56 POST ;Post install 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 POST1 74 75 76 77 78 79 80 81 82 83 84 85 POST2 86 87 88 89 90 91 92 93 94 95 96 97 POST3 98 99 100 101 102 103 104 105 106 107 108 109 POST4 110 111 112 113 114 115 116 117 118 119 120 121 POST5 122 123 124 125 126 127 128 129 130 131 132 57 ; 58 ; Check for RPMS system with V LAB file. 59 ; 60 I $$VFILE^DILFD(9000010.09)'=1 Q 61 ; 62 S %=$$NEWCP^XPDUTL("RPMS1","POST1^C0CENV") 63 S %=$$NEWCP^XPDUTL("RPMS2","POST2^C0CENV") 64 S %=$$NEWCP^XPDUTL("RPMS3","POST3^C0CENV") 65 S %=$$NEWCP^XPDUTL("RPMS4","POST4^C0CENV") 66 S %=$$NEWCP^XPDUTL("RPMS5","POST5^C0CENV") 67 S %=$$NEWCP^XPDUTL("RPMS6","POST6^C0CENV") 68 S %=$$NEWCP^XPDUTL("RPMS7","POST7^C0CENV") 69 ; 70 Q 71 ; 72 ; 73 POST1 ; Checkpoint call back entry point. 74 ; Add new style ALR1 cross-reference to V LAB file. 75 ; 76 N MSG 77 S MSG="Starting installation of ALR1 cross-reference at "_$$HTE^XLFDT($H,"1Z") 78 D BMES(MSG) 79 D ALR1^C0CLA7DD 80 S MSG="Installation of ALR1 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 81 D BMES(MSG) 82 Q 83 ; 84 ; 85 POST2 ; Checkpoint call back entry point. 86 ; Add new style ALR2 cross-reference to V LAB file. 87 ; 88 N MSG 89 S MSG="Starting installation of ALR2 cross-reference at "_$$HTE^XLFDT($H,"1Z") 90 D BMES(MSG) 91 D ALR2^C0CLA7DD 92 S MSG="Installation of ALR2 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 93 D BMES(MSG) 94 Q 95 ; 96 ; 97 POST3 ; Checkpoint call back entry point. 98 ; Add new style ALR3 cross-reference to V LAB file. 99 ; 100 N MSG 101 S MSG="Starting installation of ALR3 cross-reference at "_$$HTE^XLFDT($H,"1Z") 102 D BMES(MSG) 103 D ALR3^C0CLA7DD 104 S MSG="Installation of ALR3 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 105 D BMES(MSG) 106 Q 107 ; 108 ; 109 POST4 ; Checkpoint call back entry point. 110 ; Add new style ALR4 cross-reference to V LAB file. 111 ; 112 N MSG 113 S MSG="Starting installation of ALR4 cross-reference at "_$$HTE^XLFDT($H,"1Z") 114 D BMES(MSG) 115 D ALR4^C0CLA7DD 116 S MSG="Installation of ALR4 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 117 D BMES(MSG) 118 Q 119 ; 120 ; 121 POST5 ; Checkpoint call back entry point. 122 ; Add new style ALR5 cross-reference to V LAB file. 123 ; 124 N MSG 125 S MSG="Starting installation of ALR5 cross-reference at "_$$HTE^XLFDT($H,"1Z") 126 D BMES(MSG) 127 D ALR5^C0CLA7DD 128 S MSG="Installation of ALR5 cross-reference completed at "_$$HTE^XLFDT($H,"1Z") 129 D BMES(MSG) 130 Q 131 ; 132 ; 133 133 POST6 ; Checkpoint call back entry point. 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 POST7 170 171 172 173 174 175 134 ; Check for RPMS system and determine LAB patch level 135 ; and need to load in C0C version of LA7 routines. 136 ; 137 N MSG 138 ; 139 ; Load and rename C0CQRY2 to LA7QRY2 if LA*5.2*69 not installed 140 I '$$PATCH^XPDUTL("LA*5.2*69") D 141 . S MSG="This system missing LAB patch LA*5.2*69" 142 . D BMES(MSG) 143 . S MSG="Renaming routine C0CQRY2 to LA7QRY2" 144 . D BMES(MSG) 145 . D LOAD("C0CQRY2") 146 . D SAVE("C0CQRY2","LA7QRY2") 147 ; 148 ; Load and rename C0CVOBX1 to LA7VOBX1 if LA*5.2*64 not installed. 149 I '$$PATCH^XPDUTL("LA*5.2*64") D 150 . S MSG="This system missing LAB patch LA*5.2*64" 151 . D BMES(MSG) 152 . S MSG="Renaming routine C0CVOBX1 to LA7VOBX1" 153 . D BMES(MSG) 154 . D LOAD("C0CVOBX1") 155 . D SAVE("C0CVOBX1","LA7VOBX1") 156 ; 157 ; Load and rename C0CQRY1 to LA7QRY1 if LA*5.2*68 not installed. 158 I '$$PATCH^XPDUTL("LA*5.2*68") D 159 . S MSG="This system missing LAB patch LA*5.2*68" 160 . D BMES(MSG) 161 . S MSG="Renaming routine C0CQRY1 to LA7QRY1" 162 . D BMES(MSG) 163 . D LOAD("C0CQRY1") 164 . D SAVE("C0CQRY1","LA7QRY1") 165 ; 166 Q 167 ; 168 ; 169 POST7 ; Checkpoint call back entry point. 170 ; 171 D REINDEX^C0CLA7DD 172 ; 173 Q 174 ; 175 ; 176 176 BMES(STR) ; Write BMES^XPDUTL statements 177 178 179 180 181 182 183 LOAD(X) 184 185 186 187 188 189 190 191 SAVE(OLD,NEW) 192 193 194 195 177 ; 178 D BMES^XPDUTL($$CJ^XLFSTR(STR,IOM)) 179 ; 180 Q 181 ; 182 ; 183 LOAD(X) ; load routine X 184 N %N,DIF,XCNP 185 K ^TMP($J,X) 186 S DIF="^TMP($J,X,",XCNP=0 187 X ^%ZOSF("LOAD") 188 Q 189 ; 190 ; 191 SAVE(OLD,NEW) ; restore routine X 192 N %,DIE,X,XCM,XCN,XCS 193 S DIE="^TMP($J,"""_OLD_""",",XCN=0,X=NEW 194 X ^%ZOSF("SAVE") 195 Q -
ccr/trunk/p/C0CEVC.m
r1267 r1336 1 C0CEVC 1 C0CEVC ; CCDCCR/GPL - SUPPORT FOR EWD VISTCOM PAGES ; 3/1/2010 2 2 ;;1.0;C0C;;Mar 1, 2010; 3 3 gpltest2 ; experiment with sending a CCR to an ewd page -
ccr/trunk/p/C0CEWD.m
r1331 r1336 1 C0CEWD 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 TOKEN() 23 24 25 STORE(ZARY) 26 27 28 29 30 31 32 33 GET(C0ERTN,C0ETOKEN,NOKILL) 34 35 36 37 38 39 40 41 42 URLTOKEN(sessid) 43 44 45 46 47 48 49 50 cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options) 51 52 53 54 55 56 57 58 59 60 61 62 63 64 set1 65 66 67 68 test1(sessid) 69 70 71 1 C0CEWD ; CCDCCR/GPL - CCR EWD utilities; 1/6/11 2 ;;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
r1331 r1336 1 C0CFM1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 PUTRIM(DFN,ZWHICH) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 PUTRIM1(DFN,ZZTYP,ZVARS) 40 41 42 43 44 45 46 47 48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 VARPTR(ZVAR,ZTYP) 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 BLDTYPS 118 119 120 121 122 123 124 125 FIXSEC 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 SETFDA(C0CSN,C0CSV) 143 144 145 146 147 148 149 150 151 152 ZFILE(ZFN,ZTAB) 153 154 155 156 157 158 159 160 ZFIELD(ZFN,ZTAB) 161 162 163 164 165 166 167 168 169 ZVALUE(ZFN,ZTAB) 170 171 172 173 174 175 176 177 1 C0CFM1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.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 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 25 ; 26 S C0CGLB=$NA(^TMP("GPLRIM","VARS",DFN)) 27 I '$D(ZWHICH) S ZWHICH="ALL" 28 I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED 29 . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) 30 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION 31 E D ; MULTIPLE SECTIONS 32 . S C0CVARS=$NA(@C0CGLB) 33 . S C0CI="" 34 . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION 35 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION 36 . . D PUTRIM1(DFN,C0CI,C0CVARSN) 37 Q 38 ; 39 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 40 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" 41 S C0CX=0 42 F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE 43 . W "ZOCC=",C0CX,! 44 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE 45 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE 46 Q 47 ; 48 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 49 ; ^C0C(171.201, DFN IS THE PATIENT IEN PASSED BY VALUE 50 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 51 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 52 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 53 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 54 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 55 ; 56 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 57 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 58 N ZF,ZFV S ZF=171.201 S ZFV=171.2012 59 S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS 60 N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER 61 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 62 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 63 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 64 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 65 S C0CFDA(ZF,"?+1,",.01)=DFN 66 S C0CFDA(ZF,"?+1,",.02)=ZSRC 67 S C0CFDA(ZF,"?+1,",.03)=ZTYPN 68 S C0CFDA(ZF,"?+1,",.04)=ZOCC ;CREATE OCCURANCE 69 K ZERR 70 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER 71 I $D(ZERR) B ;OOPS 72 K C0CFDA 73 S ZD0=$O(^C0C(ZF,"C",DFN,ZSRC,ZTYPN,ZOCC,"")) 74 W "RECORD NUMBER: ",ZD0,! 75 ;B 76 S ZCNT=0 77 S ZC0CI="" ; 78 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 79 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 80 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 81 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 82 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 83 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN 84 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) 85 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN 86 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) 87 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" 88 ;S GT1(170,"?+1,",12)="DIR" 89 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" 90 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" 91 D CLEAN^DILF 92 D UPDATE^DIE("","C0CFDA","","ZERR") 93 Q 94 ; 95 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 96 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 97 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 98 ; 99 N ZCCRD,ZVARN,C0CFDA2 100 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 101 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 102 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 103 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 104 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 105 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 106 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 107 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 108 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 109 . I $D(ZERR) D ; LAYGO ERROR 110 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 111 . E D ; 112 . . D CLEAN^DILF ; CLEAN UP 113 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 114 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 115 Q ZVARN 116 ; 117 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 118 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED 119 ; 120 N C0CDIC,C0CNODE ; 121 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY 122 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE 123 Q 124 ; 125 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 126 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET 127 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS 128 ; CONVERSION 129 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX 130 D FIELDS^C0CRNF("C0CC",170) 131 S C0CI="" 132 F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION 133 . S C0CZX="" 134 . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE 135 . . W "SECTION ",C0CI," VAR ",C0CZX 136 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) 137 . . W " TYPE: ",C0CV,! 138 . . D SETFDA("SECTION",C0CV) 139 . . ;ZWR C0CFDA 140 Q 141 ; 142 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 143 ; TO SET TO VALUE C0CSV. 144 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 145 ; C0CSN,C0CSV ARE PASSED BY VALUE 146 ; 147 N C0CSI,C0CSJ 148 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 149 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 150 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 151 Q 152 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 153 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 154 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 155 I '$D(ZTAB) S ZTAB="C0CA" 156 N ZR 157 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 158 E S ZR="" 159 Q ZR 160 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 161 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 162 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 163 I '$D(ZTAB) S ZTAB="C0CA" 164 N ZR 165 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 166 E S ZR="" 167 Q ZR 168 ; 169 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 170 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 171 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 172 I '$D(ZTAB) S ZTAB="C0CA" 173 N ZR 174 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 175 E S ZR="" 176 Q ZR 177 ; -
ccr/trunk/p/C0CFM2.m
r1331 r1336 1 C0CFM2 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 RIMTBL(ZWHICH) 31 32 33 34 35 36 37 38 39 40 41 PUTRIM(DFN,ZWHICH) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 PUTRIM1(DFN,ZZTYP,ZVARS) 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 UPDIE 148 149 150 151 152 153 154 155 156 157 158 CHECK 159 160 161 162 163 164 165 166 167 CHKELS(DFN) 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 DOIT(DFN) 189 190 191 192 193 SETXUP 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 VARPTR(ZVAR,ZTYP) 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 BLDTYPS 303 304 305 306 307 308 309 310 FIXSEC 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 SETFDA(C0CSN,C0CSV) 328 329 330 331 332 333 334 335 336 337 ZFILE(ZFN,ZTAB) 338 339 340 341 342 343 344 345 ZFIELD(ZFN,ZTAB) 346 347 348 349 350 351 352 353 354 ZVALUE(ZFN,ZTAB) 355 356 357 358 359 360 361 362 1 C0CFM2 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 2 ;;1.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 RIMTBL(ZWHICH) ; PUT ALL PATIENT IN RIMTBL ZWHICH INTO THE CCR ELEMENTS FILE 31 ; 32 I '$D(RIMBASE) D ASETUP^C0CRIMA ; FOR COMMAND LINE CALLS 33 N ZI,ZJ,ZC,ZPATBASE 34 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",ZWHICH)) 35 S ZI="" 36 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 37 . S ZI=$O(@ZPATBASE@(ZI)) 38 . D PUTRIM(ZI) ; EXPORT THE PATIENT TO A FILE 39 Q 40 ; 41 PUTRIM(DFN,ZWHICH) ;DFN IS PATIENT , WHICH IS ELEMENT TYPE 42 ; 43 S C0CGLB=$NA(^TMP("C0CRIM","VARS",DFN)) 44 I '$D(ZWHICH) S ZWHICH="ALL" 45 I ZWHICH'="ALL" D ; SINGLE SECTION REQUESTED 46 . S C0CVARS=$NA(@C0CGLB@(ZWHICH)) 47 . D PUTRIM1(DFN,ZWHICH,C0CVARS) ; IF ONE SECTION 48 E D ; MULTIPLE SECTIONS 49 . S C0CVARS=$NA(@C0CGLB) 50 . S C0CI="" 51 . F S C0CI=$O(@C0CVARS@(C0CI)) Q:C0CI="" D ;FOR EACH SECTION 52 . . S C0CVARSN=$NA(@C0CVARS@(C0CI)) ; GRAB ONE SECTION 53 . . D PUTRIM1(DFN,C0CI,C0CVARSN) 54 Q 55 ; 56 PUTRIM1(DFN,ZZTYP,ZVARS) ; PUT ONE SECTION OF VARIABLES INTO CCR ELEMENTS 57 ; ZVARS IS PASSED BY NAME AN HAS THE FORM @ZVARS@(1,"VAR1")="VAL1" 58 S C0CX=0 59 F S C0CX=$O(@ZVARS@(C0CX)) Q:C0CX="" D ; FOR EACH OCCURANCE 60 . W "ZOCC=",C0CX,! 61 . K C0CMDO ; MULTIPLE SUBELEMENTS FOR THIS OCCURANCE PASSED BY NAME 62 . S C0CV=$NA(@ZVARS@(C0CX)) ; VARIABLES FOR THIS OCCURANCE 63 . D PUTELS(DFN,ZZTYP,C0CX,C0CV) ; PUT THEM TO THE CCR ELEMENTS FILE 64 . I $D(C0CMDO) D ; MULTIPLES TO HANDLE (THIS IS INSTEAD OF RECURSION :() 65 . . N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV 66 . . S ZZCNT=0 67 . . S ZZC0CI=0 68 . . S ZZVALS=$NA(@C0CMDO@("M")) ; LOCATION OF THIS MULTILPE 69 . . S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE 70 . . S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR 71 . . W "MULTIPLE:",ZZVALS,! 72 . . ;B 73 . . F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE 74 . . . S ZZCNT=ZZCNT+1 ;INCREMENT COUNT 75 . . . W "COUNT:",ZZCNT,! 76 . . . S ZV=$NA(@ZZVALS@(ZZC0CI)) 77 . . . D PUTELS(DFN,ZT,C0CX_";"_ZZCNT,ZV) 78 Q 79 ; 80 PUTELS(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 81 ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE 82 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 83 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 84 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 85 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 86 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 87 ; 88 N PATN,ZTYPN,XD0,ZTYP 89 I '$D(ZSRC) S ZSRC=1 ; CCR SOURCE IS ASSUMED, 1 IF NOT SET 90 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 91 N C0CFPAT S C0CFPAT=171.101 ; FILE AT PATIENT LEVEL 92 N C0CFSRC S C0CFSRC=171.111 ; FILE AT CCR SOURCE LVL 93 N C0CFTYP S C0CFTYP=171.121 ; FILE AT ELEMENT TYPE LVL 94 N C0CFOCC S C0CFOCC=171.131 ; FILE AT OCCURANCE LVL 95 N C0CFVAR S C0CFVAR=171.1311 ; FILE AT VARIABLE LVL 96 ;FILE IS ^C0CE(PAT,1,SCR,1,TYP,1,OCC,1,VAR,1, ... 97 ; AND WE HAVE TO ADD THEM LEVEL AT A TIME I THINK 98 N C0CFDA 99 S C0CFDA(C0CFPAT,"?+1,",.01)=DFN 100 D UPDIE ; ADD THE PATIENT 101 S PATN=$O(^C0CE("B",DFN,"")) ; IEN FOR THE PATIENT 102 S C0CFDA(C0CFSRC,"?+1,"_PATN_",",.01)=ZSRC 103 D UPDIE ; ADD THE CCR SOURCE 104 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) ; FIND THE ELE TYPE 105 S C0CFDA(C0CFTYP,"?+1,"_ZSRC_","_PATN_",",.01)=ZTYPN 106 D UPDIE ; ADD THE ELEMENT TYPE 107 S ZTYP=$O(^C0CE(PATN,1,ZSRC,1,"B",ZTYPN,"")) ; IEN OF ELEMENT TYPE 108 S C0CFDA(C0CFOCC,"?+1,"_ZTYP_","_ZSRC_","_PATN_",",.01)=ZOCC ; STRING OCC 109 ; OCC IS PRECEDED BY " " TO FORCE STRING STORAGE AND PRESERVE 110 ; STRING COLLATION ON THE INDEX 111 D UPDIE ; ADD THE OCCURANCE 112 S ZD0=$O(^C0CE(PATN,1,ZSRC,1,ZTYP,1,"B",ZOCC,"")) 113 W "RECORD NUMBER: ",ZD0,! 114 ;I ZD0=32 B 115 ;I ZD0=31 B 116 N ZCNT,ZC0CI,ZVARN,C0CZ1 117 S ZCNT=0 118 S ZC0CI="" ; 119 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 120 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 121 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 122 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 123 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 124 . . S C0CZ1=ZTYP_","_ZSRC_","_PATN_"," 125 . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,.01)=ZVARN 126 . . S ZZVAL=$TR(@ZVALS@(ZC0CI),"^","|") 127 . . S C0CFDA(C0CFVAR,"?+"_ZCNT_","_ZD0_","_C0CZ1,1)=ZZVAL 128 . E D ; THIS IS A SUBELEMENT 129 . . ;PUT THE FOLLOWING BACK TO USE RECURSION 130 . . ;N ZZCNT,ZZC0CI,ZZVALS,ZT,ZZCNT,ZV 131 . . ;S ZZCNT=0 132 . . ;S ZZC0CI=0 133 . . ;S ZZVALS=$NA(@ZVALS@("M")) ; LOCATION OF THIS MULTILPE 134 . . ;S ZT=$O(@ZZVALS@("")) ; ELEMENT TYPE OF MULTIPLE 135 . . ;S ZZVALS=$NA(@ZZVALS@(ZT)) ; PAST MULTIPLE TYPE INDICATOR 136 . . ;W "MULTIPLE:",ZZVALS,! 137 . . ;B 138 . . ;F S ZZC0CI=$O(@ZZVALS@(ZZC0CI)) Q:ZZC0CI="" D ; EACH MULTIPLE 139 . . ;. S ZZCNT=ZZCNT+1 ;INCREMENT COUNT 140 . . ;. W "COUNT:",ZZCNT,! 141 . . ;. S ZV=$NA(@ZZVALS@(ZZC0CI)) 142 . . ;. D PUTELS(DFN,ZT,ZOCC_";"_ZZCNT,ZV) ; PUT THIS BACK TO DEBUG RECURSION 143 . . S C0CMDO=ZVALS ; FLAG TO HANDLE MULTIPLES (INSTEAD OF RECURSION) 144 D UPDIE ; UPDATE 145 Q 146 ; 147 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 148 K ZERR 149 D CLEAN^DILF 150 D UPDATE^DIE("","C0CFDA","","ZERR") 151 I $D(ZERR) D ; 152 . W "ERROR",! 153 . ZWR ZERR 154 . B 155 K C0CFDA 156 Q 157 ; 158 CHECK ; CHECKSUM EXPERIMENTS 159 ; 160 ;B 161 S ZG=$NA(^C0CE(DA(2),1,DA(1),1,DA)) 162 ;S G2=$NA(^C0CE(8,1,1,1,2,1,6)) 163 S X=$$CHKSUM^XUSESIG1(ZG) 164 W G1,! 165 Q 166 ; 167 CHKELS(DFN) ; CHECKSUM ALL ELEMENTS FOR A PATIENT 168 ; 169 S ZGLB=$NA(^TMP("C0CCHK")) 170 S ZPAT=$O(^C0CE("B",DFN,"")) 171 K @ZGLB@(ZPAT) ; CLEAR PREVIOUS CHECKSUMS 172 S ZSRC="" 173 F S ZSRC=$O(^C0CE(ZPAT,1,"B",ZSRC)) Q:ZSRC="" D ; 174 . W "PAT:",ZPAT," SRC:",ZSRC,! 175 . S ZEL="" 176 . F S ZEL=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL)) Q:ZEL="" D ;ELEMENTS 177 . . W "ELEMENT:",ZEL," " 178 . . S ZELE=$$GET1^DIQ(170.101,ZEL,.01,"E") ;ELEMENT NAME 179 . . W ZELE," " 180 . . S ZELI=$O(^C0CE(ZPAT,1,ZSRC,1,"B",ZEL,"")) 181 . . S ZG=$NA(^C0CE(ZPAT,1,ZSRC,1,ZELI)) 182 . . S ZCHK=$$CHKSUM^XUSESIG1(ZG) ; CHECKSUM FOR THE ELEMENT 183 . . W ZCHK,! 184 . . S @ZGLB@(ZPAT,ZELE,ZSRC)=ZCHK 185 ZWR ^TMP("C0CCHK",ZPAT,*) 186 Q 187 ; 188 DOIT(DFN) ; EXPERIMENT FOR TIMING CALLS USING mumps -dir DOIT^C0CFM2(DFN) 189 D SETXUP 190 D CHKELS(DFN) 191 Q 192 ; 193 SETXUP ; SET UP ENVIRONMENT 194 S DISYS=19 195 S DT=3090325 196 S DTIME=300 197 S DUZ=1 198 S DUZ(0)="@" 199 S DUZ(1)="" 200 S DUZ(2)=7247 201 S DUZ("AG")="I" 202 S DUZ("BUF")=1 203 S DUZ("LANG")="" 204 S IO="/dev/pts/20" 205 S IO(0)="/dev/pts/20" 206 S IO(1,"/dev/pts/20")="" 207 S IO("ERROR")="" 208 S IO("HOME")="344^/dev/pts/20" 209 S IO("ZIO")="/dev/pts/20" 210 S IOBS="$C(8)" 211 S IOF="#,$C(27,91,50,74,27,91,72)" 212 S IOM=80 213 S ION="TELNET" 214 S IOS=344 215 S IOSL=24 216 S IOST="C-VT100" 217 S IOST(0)=9 218 S IOT="VTRM" 219 S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)" 220 S U="^" 221 S X="216;DIC(4.2," 222 S XPARSYS="216;DIC(4.2," 223 S XQXFLG="^^XUP" 224 Q 225 ; 226 PUTELSOLD(DFN,ZTYPE,ZOCC,ZVALS) ; PUT CCR VALUES INTO THE CCR ELEMENTS FILE 227 ; 171.101, ^C0CE DFN IS THE PATIENT IEN PASSED BY VALUE 228 ; ZTYPE IS THE NODE TYPE IE RESULTS,PROBLEMS PASSED BY VALUE 229 ; ZOCC IS THE OCCURANCE NUMBER IE PROBLEM NUMBER 1,2,3 ETC 230 ; ZVALS ARE THE VARIABLES AND VALUES PASSED BY NAME AND IN THE FORM 231 ; @ZVALS@("VAR1")="VALUE1" FOR ALL VARIABLES IN THIS ELEMENT 232 ; AND @ZVALS@("M",SUBOCCUR,"VAR2")="VALUE2" FOR SUB VARIABLES 233 ; 234 S ZSRC=1 ; CCR SOURCE IS ASSUMED TO BE THIS EHR, WHICH IS ALWAYS SOURCE 1 235 ; PUT THIS IN PARAMETERS - SO SOURCE NUMBER FOR PROCESSING IN CONFIGURABLE 236 N ZF,ZFV S ZF=171.101 S ZFV=171.1011 237 ;S ZSUBF=171.20122 ;FILE AND SUBFILE NUMBERS 238 ;N ZSFV S ZSFV=171.201221 ; SUBFILE VARIABLE FILE NUMBER 239 N ZTYPN S ZTYPN=$O(^C0CDIC(170.101,"B",ZTYPE,"")) 240 W "ZTYPE: ",ZTYPE," ",ZTYPN,! 241 N ZVARN ; IEN OF VARIABLE BEING PROCESSED 242 ;N C0CFDA ; FDA FOR CCR ELEMENT UPDATE 243 K C0CFDA 244 S C0CFDA(ZF,"?+1,",.01)=DFN 245 S C0CFDA(ZF,"?+1,",.02)=ZSRC 246 S C0CFDA(ZF,"?+1,",.03)=ZTYPN 247 S C0CFDA(ZF,"?+1,",.04)=" "_ZOCC ;CREATE OCCURANCE 248 K ZERR 249 ;B 250 D UPDATE^DIE("","C0CFDA","","ZERR") ;ASSIGN RECORD NUMBER 251 I $D(ZERR) B ;OOPS 252 K C0CFDA 253 S ZD0=$O(^C0CE("C",DFN,ZSRC,ZTYPN,ZOCC,"")) 254 W "RECORD NUMBER: ",ZD0,! 255 ;B 256 S ZCNT=0 257 S ZC0CI="" ; 258 F S ZC0CI=$O(@ZVALS@(ZC0CI)) Q:ZC0CI="" D ; 259 . I ZC0CI'="M" D ; NOT A SUBVARIABLE 260 . . S ZCNT=ZCNT+1 ;INCREMENT COUNT 261 . . S ZVARN=$$VARPTR(ZC0CI,ZTYPE) ;GET THE POINTER TO THE VAR IN THE CCR DICT 262 . . ; WILL ALLOW FOR LAYGO IF THE VARIABLE IS NOT FOUND 263 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",.01)=ZVARN 264 . . S C0CFDA(ZFV,"?+"_ZCNT_","_ZD0_",",1)=@ZVALS@(ZC0CI) 265 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",.01)=ZVARN 266 . . ;S C0CFDA(ZSFV,"+1,"_DFN_","_ZSRC_","_ZTYPN_","_ZOCC_",",1)=@ZVALS@(ZC0CI) 267 ;S GT1(170,"?+1,",.01)="ZZZ NEW MEDVEHICLETEXT" 268 ;S GT1(170,"?+1,",12)="DIR" 269 ;S GT1(171.201221,"?+1,1,5,1,",.01)="ZZZ NEW MEDVEHICLETEXT" 270 ;S GT1(171.201221,"+1,1,5,1,",1)="THIRD NEW MED DIRECTION TEXT" 271 D CLEAN^DILF 272 D UPDATE^DIE("","C0CFDA","","ZERR") 273 I $D(ZERR) D ; 274 . W "ERROR",! 275 . ZWR ZERR 276 . B 277 K C0CFDA 278 Q 279 ; 280 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 281 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 282 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 283 ; 284 N ZCCRD,ZVARN,C0CFDA2 285 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 286 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 287 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 288 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 289 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 290 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 291 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 292 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 293 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 294 . I $D(ZERR) D ; LAYGO ERROR 295 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 296 . E D ; 297 . . D CLEAN^DILF ; CLEAN UP 298 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 299 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 300 Q ZVARN 301 ; 302 BLDTYPS ; ROUTINE TO POPULATE THE CCR NODE TYPES FILE (^C0CDIC(170.101,) 303 ; THE CCR DICTIONARY (^C0CDIC(170, ) HAS MOST OF WHAT'S NEEDED 304 ; 305 N C0CDIC,C0CNODE ; 306 S C0CDIC=$$FILEREF^C0CRNF(170) ; CLOSED FILE REFERENCE TO THE CCR DICTIONARY 307 S C0CNODE=$$FILEREF^C0CRNF(170.101) ; CLOSED REF TO CCR NODE TYPE FILE 308 Q 309 ; 310 FIXSEC ;FIX THE SECTION FIELD OF THE CCR DICTIONARY.. IT HAS BEEN REDEFINED 311 ; AS A POINTER TO CCR NODE TYPE INSTEAD OF BEING A SET 312 ; THE SET VALUES ARE PRESERVED IN ^KBAI("SECTION") TO FACILITATE THIS 313 ; CONVERSION 314 ;N C0CC,C0CI,C0CJ,C0CN,C0CZX 315 D FIELDS^C0CRNF("C0CC",170) 316 S C0CI="" 317 F S C0CI=$O(^KBAI("SECTION",C0CI)) Q:C0CI="" D ; EACH SECTION 318 . S C0CZX="" 319 . F S C0CZX=$O(^KBAI("SECTION",C0CI,C0CZX)) Q:C0CZX="" D ; EACH VARIABLE 320 . . W "SECTION ",C0CI," VAR ",C0CZX 321 . . S C0CV=$O(^C0CDIC(170.101,"B",C0CI,"")) 322 . . W " TYPE: ",C0CV,! 323 . . D SETFDA("SECTION",C0CV) 324 . . ;ZWR C0CFDA 325 Q 326 ; 327 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 328 ; TO SET TO VALUE C0CSV. 329 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 330 ; C0CSN,C0CSV ARE PASSED BY VALUE 331 ; 332 N C0CSI,C0CSJ 333 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 334 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 335 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 336 Q 337 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 338 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 339 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 340 I '$D(ZTAB) S ZTAB="C0CA" 341 N ZR 342 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 343 E S ZR="" 344 Q ZR 345 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 346 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 347 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 348 I '$D(ZTAB) S ZTAB="C0CA" 349 N ZR 350 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 351 E S ZR="" 352 Q ZR 353 ; 354 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 355 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 356 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 357 I '$D(ZTAB) S ZTAB="C0CA" 358 N ZR 359 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 360 E S ZR="" 361 Q ZR 362 ; -
ccr/trunk/p/C0CIM2.m
r1331 r1336 1 C0CIM2 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(IMMXML,DFN,IMMOUT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 GETRPMS(DFN,C0CIMM) 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 IMMUN 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 FORECAST 102 103 104 CONTRA 105 106 107 REFUSE 108 109 110 111 MAP(IMMXML,C0CIMM,IMMOUT) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 1 C0CIM2 ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 01/27/10 2 ;;1.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
r1331 r1336 1 C0CIMMU 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 MAP(IPXML,DFN,OUTXML) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 EXTRACT(IPXML,DFN,OUTXML) 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 1 C0CIMMU ; CCDCCR/GPL - CCR/CCD PROCESSING FOR IMMUNIZATIONS ; 2/2/09 2 ;;1.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 MAP(IPXML,DFN,OUTXML) ; MAP IMMUNIZATIONS 25 ; 26 N C0CZV,C0CZVI ; TO STORE MAPPED VARIABLES 27 N C0CZT ; TMP ARRAY OF MAPPED XML 28 S C0CZV=$NA(^TMP("C0CCCR",$J,"IMMUNE")) ; TEMP STORAGE FOR VARIABLES 29 D EXTRACT(IPXML,DFN,OUTXML) ;EXTRACT THE VARIABLES 30 N C0CZI,C0CZIC ; COUNT OF IMMUNIZATIONS 31 S C0CZIC=$G(@C0CZV@(0)) ; TOTAL FROM VARIABLE ARRAY 32 I C0CZIC>0 D ;IMMUNIZATIONS FOUND 33 . F C0CZI=1:1:C0CZIC D ;FOR EACH IMMUNIZATION 34 . . S C0CZVI=$NA(@C0CZV@(C0CZI)) ;THIS IMMUNIZATION 35 . . D MAP^C0CXPATH(IPXML,C0CZVI,"C0CZT") ;MAP THE VARIABLES TO XML 36 . . I C0CZI=1 D ; FIRST ONE 37 . . . D CP^C0CXPATH("C0CZT",OUTXML) ;JUST COPY RESULTS 38 . . E D ;NOT THE FIRST 39 . . . D INSINNER^C0CXPATH(OUTXML,"C0CZT") 40 E S @OUTXML@(0)=0 ; SIGNAL NO IMMUNIZATIONS 41 N IMMUTMP,I 42 D MISSING^C0CXPATH(OUTXML,"IMMUTMP") ; SEARCH XML FOR MISSING VARS 43 I IMMUTMP(0)>0 D ; IF THERE ARE MISSING VARS - 44 . ; STRINGS MARKED AS @@X@@ 45 . W !,"IMMUNE Missing list: ",! 46 . F I=1:1:IMMUTMP(0) W IMMUTMP(I),! 47 Q 48 ; 49 EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT IMMUNIZATIONS INTO VARIABLES 50 ; 51 ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 52 ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE 53 ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE 54 ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS 55 ; INSERT^C0CXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT 56 ; 57 N RPCRSLT,J,K,PTMP,X,VMAP,TBU 58 S TVMAP=$NA(^TMP("C0CCCR",$J,"IMMUNE")) 59 S TARYTMP=$NA(^TMP("C0CCCR",$J,"IMMUARYTMP")) 60 S IMMA=$NA(^TMP("PXI",$J)) ; 61 K @IMMA ; CLEAR OUT PREVIOUS RESULTS 62 K @TVMAP,@TARYTMP ; KILL OLD ARRAY VALUES 63 D IMMUN^PXRHS03(DFN) ; 64 I $O(@IMMA@(""))="" D Q ; RPC RETURNS NULL 65 . W "NULL RESULT FROM IMMUN^PXRHS03 ",! 66 . S @TVMAP@(0)=0 67 N C0CIM,C0CC,C0CIMD,C0CIEN,C0CT ; 68 S C0CIM="" 69 S C0CC=0 ; COUNT 70 F S C0CIM=$O(@IMMA@(C0CIM)) Q:C0CIM="" D ; FOR EACH IMMUNE TYPE IN THE LIST 71 . S C0CC=C0CC+1 ;INCREMENT COUNT 72 . S @TVMAP@(0)=C0CC ; SAVE NEW COUNT TO ARRAY 73 . S VMAP=$NA(@TVMAP@(C0CC)) ; THIS IMMUNE ELEMENT 74 . K @VMAP ; MAKE SURE IT IS CLEARED OUT 75 . W C0CIM,! 76 . S C0CIMD="" ; IMMUNE DATE 77 . F S C0CIMD=$O(@IMMA@(C0CIM,C0CIMD)) Q:C0CIMD="" D ; FOR EACH DATE 78 . . S C0CIEN=$O(@IMMA@(C0CIM,C0CIMD,"")) ;IEN OF IMMUNE RECORD 79 . . D GETN^C0CRNF("C0CI",9000010.11,C0CIEN) ; GET THE FILEMAN RECORD FOR IENS 80 . . W C0CIEN,"_",C0CIMD 81 . . S C0CT=$$FMDTOUTC^C0CUTIL(9999999-C0CIMD,"DT") ; FORMAT DATE/TIME 82 . . W C0CT,! 83 . . S @VMAP@("IMMUNEOBJECTID")="IMMUNIZATION_"_C0CC ;UNIQUE OBJECT ID 84 . . S @VMAP@("IMMUNEDATETIMETYPETEXT")="Immunization Date" ; ALL ARE THE SAME 85 . . S @VMAP@("IMMUNEDATETIME")=C0CT ;FORMATTED DATE/TIME 86 . . S C0CIP=$$ZVALUEI^C0CRNF("ENCOUNTER PROVIDER","C0CI") ;IEN OF PROVIDER 87 . . S @VMAP@("IMMUNESOURCEACTORID")="ACTORPROVIDER_"_C0CIP 88 . . S C0CIIEN=$$ZVALUEI^C0CRNF("IMMUNIZATION","C0CI") ;IEN OF IMMUNIZATION 89 . . I $G(DUZ("AG"))="I" D ; RUNNING IN RPMS 90 . . . D GETN^C0CRNF("C0CZIM",9999999.14,C0CIIEN) ;GET IMMUNE RECORD 91 . . . S C0CIN=$$ZVALUE^C0CRNF("NAME","C0CZIM") ; USE NAME IN IMMUNE RECORD 92 . . . ; FOR LOOKING UP THE CODE 93 . . . ; GET IT FROM THE CODE FILE 94 . . . S C0CICD=$$ZVALUE^C0CRNF("HL7-CVX CODE","C0CZIM") ;CVX CODE 95 . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME 96 . . . S @VMAP@("IMMUNEPRODUCTCODE")=C0CICD ; CVX CODE 97 . . . I C0CICD'="" S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="CDC Vaccine Code" ; 98 . . . E S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NULL 99 . . E D ; NOT IN RPMS 100 . . . S C0CIN=$$ZVALUE^C0CRNF("IMMUNIZATION","C0CI") ;NAME OF IMMUNIZATION 101 . . . S @VMAP@("IMMUNEPRODUCTNAMETEXT")=C0CIN ;NAME 102 . . . S @VMAP@("IMMUNEPRODUCTCODE")="" ; CVX CODE 103 . . . S @VMAP@("IMMUNEPRODUCTCODESYSTEM")="" ;NO CODE 104 N C0CIRIM S C0CIRIM=$NA(^TMP("C0CRIM","VARS",DFN,"IMMUNE")) 105 M @C0CIRIM=@TVMAP ; PERSIST RIM VARIABLES 106 Q 107 ; -
ccr/trunk/p/C0CIN.m
r1331 r1336 1 C0CIN 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 TEST 24 25 26 27 28 29 30 RPCAIN(RTN,DFN,DUZ,SOURCE,TYPE,ARY) 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 ADDSRC(ZSRC) 50 51 52 53 54 55 56 57 58 RPCFIN(RTN,DFN,DUZ,SOURCE,TYPE,FN,FP) 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 RPCLIST(RTN,DFN) 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 RPCDOC(RTN,IEN) 98 99 100 101 102 103 EN(INXML,SOURCE,C0CDFN) 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 GETACCR(AOUT,C0CDFN) 132 133 134 135 136 137 138 TEST64 139 140 141 142 143 144 145 146 147 NORMAL(OUTXML,INXML) 148 149 150 151 152 153 154 155 156 157 158 159 CLEANCR(OUTXML,INXML) 160 161 162 163 164 165 166 167 168 169 LOAD(ZRTN,filepath) 170 171 172 173 174 175 176 177 178 179 180 181 182 183 UPDIE 184 185 186 187 188 189 190 191 192 193 1 C0CIN ; CCDCCR/GPL - CCR IMPORT utilities; 9/20/08 2 ;;1.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 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 184 K ZERR,C0CIEN 185 D CLEAN^DILF 186 D UPDATE^DIE("","C0CFDA","C0CIEN","ZERR") 187 I $D(ZERR) D ; 188 . W "ERROR",! 189 . ZWR ZERR 190 . B 191 K C0CFDA 192 Q 193 ; -
ccr/trunk/p/C0CLA7DD.m
r558 r1336 211 211 S MSG="Starting indexing of ALR1, ALR2, ALR4, ALR5 indexes - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") 212 212 D BMES(MSG),SENDXQA(MSG) 213 213 ; 214 214 S DIK="^AUPNVLAB(" 215 215 S DIK(1)=".02^ALR1^ALR2^ALR4^ALR5" … … 222 222 S MSG="Elapsed Time: "_$$HDIFF^XLFDT(C0CHLOG("END"),C0CHLOG("START"),3) 223 223 D BMES(MSG) 224 224 ; 225 225 S C0CHLOG("START")=$H 226 226 S MSG="Starting indexing of ALR3 index - "_$$HTE^XLFDT(C0CHLOG("START"),"1Z") … … 249 249 ; 250 250 ; 251 SENDXQA(MSG) 252 253 254 255 256 257 258 259 251 SENDXQA(MSG) ; Send alert for reindex status 252 ; 253 N XQA,XQAMSG 254 ; 255 S XQA(DUZ)="" 256 S XQAMSG=MSG 257 D SETUP^XQALERT 258 ; 259 Q -
ccr/trunk/p/C0CLA7Q.m
r1204 r1336 1 C0CLA7Q 2 3 4 5 6 7 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 VCHECK 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 VBUILD 64 65 66 67 68 69 LNCHK 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 TMPCHK 114 115 116 117 118 119 120 121 122 123 124 125 126 VCHK1 127 128 129 130 131 132 133 134 135 136 137 138 VSTORE 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 FINDDT 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 1 C0CLA7Q ;WV/JMC - CCD/CCR Lab HL7 Query Utility ;Jul 6, 2009 2 ;;1.0;C0C;;May 19, 2009;Build 38 3 ; 4 ; 5 Q 6 ; 7 ; 8 LAB(C0CPTID,C0CSDT,C0CEDT,C0CSC,C0CSPEC,C0CERR,C0CDEST,C0CHL7) ; Entry point for Lab Result Query 9 ; 10 ; 11 K ^TMP("C0C-VLAB",$J) 12 ; 13 ; Check and retrieve lab results from LAB DATA file (#63) 14 S C0CDEST=$$GCPR^LA7QRY($G(C0CPTID),$G(C0CSDT),$G(C0CEDT),.C0CSC,.C0CSPEC,.C0CERR,$G(C0CDEST),$G(C0CHL7)) 15 ; 16 ; If V LAB file present then check for lab results that are only in this file 17 ; If results found in V Lab file then build results and add to above results. 18 I $D(^AUPNVLAB) D 19 . D VCHECK 20 . I $D(^TMP("C0C-VLAB",$J,3)) D VBUILD 21 ; 22 ;K ^TMP("C0C-VLAB",$J) 23 ; 24 Q C0CDEST 25 ; 26 ; 27 VCHECK ; If V LAB file present then check for lab results that are only in this file. 28 ; 29 N C0CDA,C0CEND,C0CROOT,C0CVLAB,LA7PTID,LA7SC,LA7SCRC,LA7SPEC 30 ; 31 S LA7PTID=C0CPTID 32 D PATID^LA7QRY2 33 I $D(LA7ERR) Q 34 ; 35 ; Resolve search codes to lab datanames 36 S LA7SC=$G(C0CSC) 37 I $T(SCLIST^LA7QRY2)'="" D 38 . N TMP 39 . S LA7SCRC=$G(C0CSC) 40 . S TMP=$$SCLIST^LA7QRY2(LA7SCRC) 41 . S LA7SC=TMP 42 ; 43 I LA7SC'="*" D CHKSC^LA7QRY1 44 ; 45 ; Convert specimen codes to file #61 Topography entries 46 S LA7SPEC=$G(C0CSPEC) 47 I LA7SPEC'="*" D SPEC^LA7QRY1 48 ; 49 S C0CROOT="^AUPNVLAB(""ALR4"",DFN,C0CSDT)",C0CEND=0 50 ; 51 F S C0CROOT=$Q(@C0CROOT) Q:C0CROOT="" D Q:C0CEND 52 . I $QS(C0CROOT,1)'="ALR4"!($QS(C0CROOT,2)'=DFN) S C0CEND=1 Q ; Left x-ref or patient 53 . I $QS(C0CROOT,3)>C0CEDT S C0CEND=1 Q ; Exceeded end date/time 54 . S C0CDA=$QS(C0CROOT,4) 55 . I $D(^TMP("C0C-VLAB",$J,1,C0CDA)) Q ; Already checked during scan of file #63 56 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)=1 Q ; Source is LAB DATA file - skip 57 . D VCHK1 58 ; 59 ; 60 Q 61 ; 62 ; 63 VBUILD ; Build results found only in V LAB file into HL7 structure. 64 ; 65 ; 66 Q 67 ; 68 ; 69 LNCHK ; Check for corresponding entry in V LAB file and related LOINC code for a result in file #63. 70 ; Call from LA7QRY2 71 ; 72 N DFN,C0C60,C0C63,C0CACC,C0CDA,C0CDT,C0CLN,C0CPDA,C0CPTEST,C0CSPEC,C0CTEST,X 73 ; 74 S DFN=$P(^LR(LRDFN,0),"^",3) 75 S C0C63(0)=^LR(LRDFN,LRSS,LRIDT,0) 76 S C0CDT=$P(C0C63(0),"^"),C0CACC=$P(C0C63(0),"^",6),C0CSPEC=$P(C0C63(0),"^",5) 77 S (C0CTEST,C0CTEST(64),C0CPTEST,C0CPTEST(64),C0CLN)="" 78 ; 79 ; ^AUPNVLAB("ALR1",5380,"EKT 0307 48",173,3080307.211055,5427197)="" 80 ; 81 S C0C60="" 82 F S C0C60=$O(^LAB(60,"C",LRSS_";"_LRSB_";1",C0C60)) Q:'C0C60 D Q:C0CLN'="" 83 . D FINDDT 84 . I C0CDA<1 Q 85 . I $P($G(^AUPNVLAB(C0CDA,11)),"^",8)'=1 Q ; Source is not LAB DATA file - skip 86 . S C0CLN=$P($G(^AUPNVLAB(C0CDA,11)),"^",13) 87 . S C0CPDA=$P($G(^AUPNVLAB(C0CDA,12)),"^",8) 88 . I C0CPDA,'$D(^AUPNVLAB(C0CPDA,0)) S C0CPDA="" ; Dangling pointer 89 . I C0CPDA="" S C0CPDA=C0CDA 90 . S C0CTEST=$P($G(^AUPNVLAB(C0CDA,0)),"^"),X=$P($G(^LAB(60,C0CTEST,64)),"^",2) 91 . I X S C0CTEST(64)=$P($G(^LAM(X,0)),"^",2) 92 . S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^"),X=$P($G(^LAB(60,C0CPTEST,64)),"^") 93 . I X S C0CPTEST(64)=$P($G(^LAM(X,0)),"^",2) 94 . S ^TMP("C0C-VLAB",$J,1,C0CDA)="" 95 . I C0CDA'=C0CPDA S ^TMP("C0C-VLAB",$J,1,C0CPDA)="" 96 . S ^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)=C0CPTEST(64)_"^"_C0CTEST(64)_"^"_C0CLN_"^"_C0CDA_"^"_C0CTEST_"^"_C0CPDA_"^"_C0CPTEST 97 ; 98 S X=$P(LA7X,"^",3) 99 ; If order NLT then update if no order NLT 100 I C0CPTEST(64),$P(X,"!")="" S $P(X,"!")=C0CPTEST(64) 101 ; 102 ; If result NLT then update if no result NLT 103 I C0CTEST(64),$P(X,"!",2)="" S $P(X,"!",2)=C0CTEST(64) 104 ; 105 ; If LOINC found then update variable with LN code 106 I C0CLN'="",$P(X,"!",3)="" S $P(X,"!",3)=C0CLN 107 ; 108 S $P(LA7X,"^",3)=X 109 ; 110 Q 111 ; 112 ; 113 TMPCHK ; Check if LN/NLT codes saved from V LAB file above and use when building OBR/OBX segments 114 ; Called from LA7VOBX1 115 ; 116 N I,X 117 ; 118 S X=$G(^TMP("C0C-VLAB",$J,2,LRDFN,LRSS,LRIDT,LRSB)) 119 I X="" Q 120 F I=1:1:3 I $P(LA7X,"!",I)="",$P(X,"^",I)'="" S $P(LA7X,"!",I)=$P(X,"^",I) 121 S $P(LA7VAL,"^",3)=LA7X 122 ; 123 Q 124 ; 125 ; 126 VCHK1 ; Check the entry in V Lab to determine if it meets criteria 127 ; 128 N C0CVLAB,I 129 ; 130 F I=0,12 S C0CVLAB(I)=$G(^AUPNVLAB(C0CDA,I)) 131 ; 132 ; JMC 04/13/09 - Store anything for now that meets date criteria. 133 D VSTORE 134 ; 135 Q 136 ; 137 ; 138 VSTORE ; Store entry for building in HL7 message when parent is from V LAB file. 139 ; 140 N C0CPDA,C0CPTEST 141 ; 142 ; Determine parent test to use for OBR segment 143 S C0CPDA=$P(C0CVLAB(12),"^",8) 144 I C0CPDA="" S C0CPDA=C0CDA 145 ; 146 ; Determine parent test 147 S C0CPTEST=$P($G(^AUPNVLAB(C0CPDA,0)),"^") 148 ; 149 S ^TMP("C0C-VLAB",$J,3,$P(C0CVLAB(0),"^",2),$P(C0CVLAB(12),"^"),C0CPTEST,C0CDA)=C0CPDA 150 ; 151 Q 152 ; 153 ; 154 FINDDT ; Find entry in V LAB for the date/time or one close to it. 155 ; RPMS stores related specimen entries under the same date/time. 156 ; Lab file #63 creates unique entries with slightly different times. 157 ; 158 S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDT,0)) 159 I C0CDA>0 Q 160 ; 161 ; If entry found then confirm that specimen type matches. 162 N C0CDTY 163 S C0CDTY=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,0)) 164 I C0CDTY D 165 . I $P(C0CDT,".")'=$P(C0CDTY,".") Q 166 . S C0CDA=$O(^AUPNVLAB("ALR1",DFN,C0CACC,C0C60,C0CDTY,0)) 167 . I C0CSPEC'=$P($G(^AUPNVLAB(C0CDA,11)),"^",3) S C0CDA="" 168 ; 169 Q -
ccr/trunk/p/C0CLABS.m
r1331 r1336 1 C0CALABS 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 MAP(MIXML,DFN,MOXML) 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 RPCMAP(RTN,DFN,RMIVAR,RMIXML) 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 EXTRACT(ILXML,DFN,OLXML) 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 GHL7 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 LIST 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 LTYP(OSEG,OTYP,OVARA,OC0CQT) 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 LOBX 262 263 264 OUT(DFN) 265 266 267 268 269 270 271 272 SETTBL 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 1 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 ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD 133 D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS 134 S C0CQT=QTSAV ; RESET SILENT FLAG 135 K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT 136 I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS 137 Q 138 ; 139 GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT 140 ; N C0CPTID,C0CSPC,C0CSDT,C0CEDT,C0CR 141 ; SET UP FOR LAB API CALL 142 S C0CPTID=$$SSN^C0CDPT(DFN) ; GET THE SSN FOR THIS PATIENT 143 I C0CPTID="" D Q ; NO SSN, COMPLAIN AND QUIT 144 . W "LAB LOOKUP FAILED, NO SSN",! 145 . S C0CNSSN=1 ; SET NO SSN FLAG 146 S C0CSPC="*" ; LOOKING FOR ALL LABS 147 ;I $D(^TMP("C0CCCR","RPMS")) D ; RUNNING RPMS 148 ;. D DT^DILF(,"T-365",.C0CSDT) ; START DATE ONE YEAR AGO TO LIMIT VOLUME 149 ;E D DT^DILF(,"T-5000",.C0CSDT) ; START DATE LONG AGO TO GET EVERYTHING 150 ;D DT^DILF(,"T",.C0CEDT) ; END DATE TODAY 151 S C0CLLMT=$$GET^C0CPARMS("LABLIMIT") ; GET THE LIMIT PARM 152 S C0CLSTRT=$$GET^C0CPARMS("LABSTART") ; GET START PARM 153 D DT^DILF(,C0CLLMT,.C0CSDT) ; 154 W "LAB LIMIT: ",C0CLLMT,! 155 D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM 156 S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW 157 S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP 158 Q 159 ; 160 LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB 161 ; 162 ; N C0CI,C0CJ,C0COBT,C0CHB,C0CVAR 163 I '$D(C0CLB) S C0CLB=$NA(^TMP("C0CCCR",$J,"RESULTS")) ; BASE GLB FOR LABS VARS 164 I '$D(C0CQT) S C0CQT=0 165 I '$D(DFN) S DFN=1 ; DEFAULT TEST PATIENT 166 I '$D(^TMP("C0CCCR","LABTBL",0)) D SETTBL ;INITIALIZE LAB TABLE 167 I ^TMP("C0CCCR","LABTBL",0)'="V3" D SETTBL ;NEED NEWEST VERSION 168 I '$D(^TMP("HLS",$J,1)) D GHL7 ; GET HL7 MGS IF NOT ALREADY DONE 169 S C0CTAB=$NA(^TMP("C0CCCR","LABTBL")) ; BASE OF OBX TABLE 170 S C0CHB=$NA(^TMP("HLS",$J)) 171 S C0CI="" 172 S @C0CLB@(0)=0 ; INITALIZE RESULTS VARS COUNT 173 F S C0CI=$O(@C0CHB@(C0CI)) Q:C0CI="" D ; FOR ALL RECORDS IN HL7 MSG 174 . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES 175 . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) 176 . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) 177 . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification 178 . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT 179 . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION 180 . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE 181 . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD 182 . M XV=C0CVAR ; 183 . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION 184 . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT 185 . . S C0CLI=@C0CLB@(0) ; INDEX FOR THIS RESULT 186 . . ;M @C0CLB@(C0CLI)=C0CVAR ; PERSIST THE OBR VARS 187 . . S XV("RESULTOBJECTID")="RESULT_"_C0CLI 188 . . S C0CX1=XV("RESULTSOURCEACTORID") ; SOURCE FROM OBR 189 . . S XV("RESULTSOURCEACTORID")="ACTORPROVIDER_"_$P($P(C0CX1,"^",1),"-",1) 190 . . S C0CX1=XV("RESULTASSESSMENTDATETIME") ;DATE TIME IN HL7 FORMAT 191 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 192 . . S XV("RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 193 . . M @C0CLB@(C0CLI)=XV ; PERSIST THE OBR VARS 194 . . S C0CLOBX=0 ; MARK THE BEGINNING OF A NEW SECTION 195 . I C0CTYP="OBX" D ; SPECIAL CASE FOR OBX3 196 . . ; RESULTTESTCODEVALUE 197 . . ; RESULTTESTDESCRIPTIONTEXT 198 . . I C0CVAR("C3")="LN" D ; PRIMARY CODE IS LOINC 199 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; THE LOINC CODE VALUE 200 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 201 . . . ;S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; DESC TXT 202 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2")_" LOINC: "_C0CVAR("C1") 203 . . E I C0CVAR("C6")="LN" D ; SECONDARY CODE IS LOINC 204 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; THE LOINC CODE VALUE 205 . . . S XV("RESULTTESTCODINGSYSTEM")="LOINC" ; DISPLAY NAME FOR LOINC 206 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; DESCRIPTION TEXT 207 . . E I C0CVAR("C6")'="" D ; NO LOINC CODES, USE SECONDARY IF PRESENT 208 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C4") ; SECONDARY CODE VALUE 209 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C6") ; SECONDARY CODE NAME 210 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C5") ; SECONDARY TEXT 211 . . E D ; NO SECONDARY, USE PRIMARY 212 . . . S XV("RESULTTESTCODEVALUE")=C0CVAR("C1") ; PRIMARY CODE VALUE 213 . . . S XV("RESULTTESTCODINGSYSTEM")=C0CVAR("C3") ; PRIMARY DISPLAY NAME 214 . . . S XV("RESULTTESTDESCRIPTIONTEXT")=C0CVAR("C2") ; USE PRIMARY TEXT 215 . . N C0CZG S C0CZG=XV("RESULTTESTNORMALDESCTEXT") ; 216 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 217 . . ;S XV("RESULTTESTNORMALDESCTEXT")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 218 . . S XV("RESULTTESTNORMALDESCTEXT")=C0CZG 219 . . S C0CZG=XV("RESULTTESTVALUE") 220 . . ; mod to remove local XML escaping rely upon MAP^C0CXPATH 221 . . ;S XV("RESULTTESTVALUE")=$$SYMENC^MXMLUTL(C0CZG) ;ESCAPE 222 . . S XV("RESULTTESTVALUE")=C0CZG 223 . I C0CTYP="OBX" D ; PROCESS TEST RESULTS 224 . . I C0CLOBX=0 D ; FIRST TEST RESULT FOR THIS SECTION 225 . . . S C0CLB2=$NA(@C0CLB@(C0CLI,"M","TEST")) ; INDENT FOR TEST RESULTS 226 . . S C0CLOBX=C0CLOBX+1 ; INCREMENT TEST COUNT 227 . . S @C0CLB2@(0)=C0CLOBX ; STORE THE TEST COUNT 228 . . S XV("RESULTTESTOBJECTID")="RESULTTEST_"_C0CLI_"_"_C0CLOBX 229 . . S C0CX1=XV("RESULTTESTSOURCEACTORID") ; TEST SOURCE 230 . . S C0CX2=$P($P(C0CX1,"^",1),"-",1) ; PULL OUT STATION NUMBER 231 . . S XV("RESULTTESTSOURCEACTORID")="ACTORORGANIZATION_"_C0CX2 232 . . S XV("RESULTTESTNORMALSOURCEACTORID")=XV("RESULTTESTSOURCEACTORID") 233 . . S C0CX1=XV("RESULTTESTDATETIME") ;DATE TIME IN HL7 FORMAT 234 . . S C0CX2=$$HL7TFM^XLFDT(C0CX1,"L") ;FM DT LOCAL 235 . . S XV("RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(C0CX2,"DT") ;UTC TIME 236 . . ; I 'C0CQT ZWR XV 237 . . M @C0CLB2@(C0CLOBX)=XV ; PERSIST THE TEST RESULT VARIABLES 238 . I 'C0CQT D ; 239 . . W C0CI," ",C0CTYP,! 240 . ; S C0CI=$O(@C0CHB@(C0CI)) 241 ;K ^TMP("C0CRIM","VARS",DFN,"RESULTS") 242 ;M ^TMP("C0CRIM","VARS",DFN,"RESULTS")=@C0CLB 243 Q 244 LTYP(OSEG,OTYP,OVARA,OC0CQT) ; 245 S OTAB=$NA(@C0CTAB@(OTYP)) ; TABLE FOR SEGMENT TYPE 246 I '$D(OC0CQT) S C0CQT=0 ; NOT C0CQT IS DEFAULT 247 E S C0CQT=OC0CQT ; ACCEPT C0CQT FLAG 248 I 1 D ; FOR HL7 SEGMENT TYPE 249 . S OI="" ; INDEX INTO FIELDS IN SEG 250 . F S OI=$O(@OTAB@(OI)) Q:OI="" D ; FOR EACH FIELD OF THE SEGMENT 251 . . S OTI=$P(@OTAB@(OI),"^",1) ; TABLE INDEX 252 . . S OVAR=$P(@OTAB@(OI),"^",4) ; CCR VARIABLE IF DEFINED 253 . . S OV=$P(OSEG,"|",OTI+1) ; PULL OUT VALUE 254 . . I $P(OI,";",2)'="" D ; THIS IS DEFINING A SUB-VALUE 255 . . . S OI2=$P(OTI,";",2) ; THE SUB-INDEX 256 . . . S OV=$P(OV,"^",OI2) ; PULL OUT SUB-VALUE 257 . . I OVAR'="" S OVARA(OVAR)=OV ; PASS BACK VARIABLE AND VALUE 258 . . I 'C0CQT D ; PRINT OUTPUT IF C0CQT IS FALSE 259 . . . I OV'="" W OI_": "_$P(@OTAB@(OI),"^",3),": ",OVAR,": ",OV,! 260 Q 261 LOBX ; 262 Q 263 ; 264 OUT(DFN) ; WRITE OUT A CCR THAT HAS JUST BEEN PROCESSED (FOR TESTING) 265 N GA,GF,GD 266 S GA=$NA(^TMP("C0CCCR",$J,DFN,"CCR",1)) 267 S GF="RPMS_CCR_"_DFN_"_"_DT_".xml" 268 S GD=^TMP("C0CCCR","ODIR") 269 W $$OUTPUT^C0CXPATH(GA,GF,GD) 270 Q 271 ; 272 SETTBL ; 273 K X ; CLEAR X 274 S X("PID","PID1")="1^00104^Set ID - Patient ID" 275 S X("PID","PID2")="2^00105^Patient ID (External ID)" 276 S X("PID","PID3")="3^00106^Patient ID (Internal ID)" 277 S X("PID","PID4")="4^00107^Alternate Patient ID" 278 S X("PID","PID5")="5^00108^Patient's Name" 279 S X("PID","PID6")="6^00109^Mother's Maiden Name" 280 S X("PID","PID7")="7^00110^Date of Birth" 281 S X("PID","PID8")="8^00111^Sex" 282 S X("PID","PID9")="9^00112^Patient Alias" 283 S X("PID","PID10")="10^00113^Race" 284 S X("PID","PID11")="11^00114^Patient Address" 285 S X("PID","PID12")="12^00115^County Code" 286 S X("PID","PID13")="13^00116^Phone Number - Home" 287 S X("PID","PID14")="14^00117^Phone Number - Business" 288 S X("PID","PID15")="15^00118^Language - Patient" 289 S X("PID","PID16")="16^00119^Marital Status" 290 S X("PID","PID17")="17^00120^Religion" 291 S X("PID","PID18")="18^00121^Patient Account Number" 292 S X("PID","PID19")="19^00122^SSN Number - Patient" 293 S X("PID","PID20")="20^00123^Drivers License - Patient" 294 S X("PID","PID21")="21^00124^Mother's Identifier" 295 S X("PID","PID22")="22^00125^Ethnic Group" 296 S X("PID","PID23")="23^00126^Birth Place" 297 S X("PID","PID24")="24^00127^Multiple Birth Indicator" 298 S X("PID","PID25")="25^00128^Birth Order" 299 S X("PID","PID26")="26^00129^Citizenship" 300 S X("PID","PID27")="27^00130^Veteran.s Military Status" 301 S X("PID","PID28")="28^00739^Nationality" 302 S X("PID","PID29")="29^00740^Patient Death Date/Time" 303 S X("PID","PID30")="30^00741^Patient Death Indicator" 304 S X("NTE","NTE1")="1^00573^Set ID - NTE" 305 S X("NTE","NTE2")="2^00574^Source of Comment" 306 S X("NTE","NTE3")="3^00575^Comment" 307 S X("ORC","ORC1")="1^00215^Order Control" 308 S X("ORC","ORC2")="2^00216^Placer Order Number" 309 S X("ORC","ORC3")="3^00217^Filler Order Number" 310 S X("ORC","ORC4")="4^00218^Placer Order Number" 311 S X("ORC","ORC5")="5^00219^Order Status" 312 S X("ORC","ORC6")="6^00220^Response Flag" 313 S X("ORC","ORC7")="7^00221^Quantity/Timing" 314 S X("ORC","ORC8")="8^00222^Parent" 315 S X("ORC","ORC9")="9^00223^Date/Time of Transaction" 316 S X("ORC","ORC10")="10^00224^Entered By" 317 S X("ORC","ORC11")="11^00225^Verified By" 318 S X("ORC","ORC12")="12^00226^Ordering Provider" 319 S X("ORC","ORC13")="13^00227^Enterer's Location" 320 S X("ORC","ORC14")="14^00228^Call Back Phone Number" 321 S X("ORC","ORC15")="15^00229^Order Effective Date/Time" 322 S X("ORC","ORC16")="16^00230^Order Control Code Reason" 323 S X("ORC","ORC17")="17^00231^Entering Organization" 324 S X("ORC","ORC18")="18^00232^Entering Device" 325 S X("ORC","ORC19")="19^00233^Action By" 326 S X("OBR","OBR1")="1^00237^Set ID - Observation Request" 327 S X("OBR","OBR2")="2^00216^Placer Order Number" 328 S X("OBR","OBR3")="3^00217^Filler Order Number" 329 S X("OBR","OBR4")="4^00238^Universal Service ID" 330 S X("OBR","OBR4;LOINC")="4;1^00238^Universal Service ID - LOINC^RESULTCODE" 331 S X("OBR","OBR4;DESC")="4;2^00238^Universal Service ID - DESC^RESULTDESCRIPTIONTEXT" 332 S X("OBR","OBR4;VACODE")="4;3^00238^Universal Service ID - VACODE^RESULTCODINGSYSTEM" 333 S X("OBR","OBR5")="5^00239^Priority" 334 S X("OBR","OBR6")="6^00240^Requested Date/Time" 335 S X("OBR","OBR7")="7^00241^Observation Date/Time^RESULTASSESSMENTDATETIME" 336 S X("OBR","OBR8")="8^00242^Observation End Date/Time" 337 S X("OBR","OBR9")="9^00243^Collection Volume" 338 S X("OBR","OBR10")="10^00244^Collector Identifier" 339 S X("OBR","OBR11")="11^00245^Specimen Action Code" 340 S X("OBR","OBR12")="12^00246^Danger Code" 341 S X("OBR","OBR13")="13^00247^Relevant Clinical Info." 342 S X("OBR","OBR14")="14^00248^Specimen Rcv'd. Date/Time" 343 S X("OBR","OBR15")="15^00249^Specimen Source" 344 S X("OBR","OBR16")="16^00226^Ordering Provider XCN^RESULTSOURCEACTORID" 345 S X("OBR","OBR17")="17^00250^Order Callback Phone Number" 346 S X("OBR","OBR18")="18^00251^Placers Field 1" 347 S X("OBR","OBR19")="19^00252^Placers Field 2" 348 S X("OBR","OBR20")="20^00253^Filler Field 1" 349 S X("OBR","OBR21")="21^00254^Filler Field 2" 350 S X("OBR","OBR22")="22^00255^Results Rpt./Status Change" 351 S X("OBR","OBR23")="23^00256^Charge to Practice" 352 S X("OBR","OBR24")="24^00257^Diagnostic Service Sect" 353 S X("OBR","OBR25")="25^00258^Result Status^RESULTSTATUS" 354 S X("OBR","OBR26")="26^00259^Parent Result" 355 S X("OBR","OBR27")="27^00221^Quantity/Timing" 356 S X("OBR","OBR28")="28^00260^Result Copies to" 357 S X("OBR","OBR29")="29^00261^Parent Number" 358 S X("OBR","OBR30")="30^00262^Transportation Mode" 359 S X("OBR","OBR31")="31^00263^Reason for Study" 360 S X("OBR","OBR32")="32^00264^Principal Result Interpreter" 361 S X("OBR","OBR33")="33^00265^Assistant Result Interpreter" 362 S X("OBR","OBR34")="34^00266^Technician" 363 S X("OBR","OBR35")="35^00267^Transcriptionist" 364 S X("OBR","OBR36")="36^00268^Scheduled Date/Time" 365 S X("OBR","OBR37")="37^01028^Number of Sample Containers" 366 S X("OBR","OBR38")="38^38^01029 Transport Logistics of Collected Sample" 367 S X("OBR","OBR39")="39^01030^Collector.s Comment" 368 S X("OBR","OBR40")="40^01031^Transport Arrangement Responsibility" 369 S X("OBR","OBR41")="41^01032^Transport Arranged" 370 S X("OBR","OBR42")="42^01033^Escort Required" 371 S X("OBR","OBR43")="43^01034^Planned Patient Transport Comment" 372 S X("OBX","OBX1")="1^00559^Set ID - OBX" 373 S X("OBX","OBX2")="2^00676^Value Type" 374 S X("OBX","OBX3")="3^00560^Observation Identifier" 375 S X("OBX","OBX3;C1")="3;1^00560^Observation Identifier^C1" 376 S X("OBX","OBX3;C2")="3;2^00560^Observation Identifier^C2" 377 S X("OBX","OBX3;C3")="3;3^00560^Observation Identifier^C3" 378 S X("OBX","OBX3;C4")="3;4^00560^Observation Identifier^C4" 379 S X("OBX","OBX3;C5")="3;5^00560^Observation Identifier^C5" 380 S X("OBX","OBX3;C6")="3;6^00560^Observation Identifier^C6" 381 S X("OBX","OBX4")="4^00769^Observation Sub-Id" 382 S X("OBX","OBX5")="5^00561^Observation Results^RESULTTESTVALUE" 383 S X("OBX","OBX6")="6^00562^Units^RESULTTESTUNITS" 384 S X("OBX","OBX7")="7^00563^Reference Range^RESULTTESTNORMALDESCTEXT" 385 S X("OBX","OBX8")="8^00564^Abnormal Flags^RESULTTESTFLAG" 386 S X("OBX","OBX9")="9^00639^Probability" 387 S X("OBX","OBX10")="10^00565^Nature of Abnormal Test" 388 S X("OBX","OBX11")="11^00566^Observ. Result Status^RESULTTESTSTATUSTEXT" 389 S X("OBX","OBX12")="12^00567^Date Last Normal Value" 390 S X("OBX","OBX13")="13^00581^User Defined Access Checks" 391 S X("OBX","OBX14")="14^00582^Date/Time of Observation^RESULTTESTDATETIME" 392 S X("OBX","OBX15")="15^00583^Producer.s ID^RESULTTESTSOURCEACTORID" 393 S X("OBX","OBX16")="16^00584^Responsible Observer" 394 S X("OBX","OBX17")="17^00936^Observation Method" 395 K ^TMP("C0CCCR","LABTBL") 396 M ^TMP("C0CCCR","LABTBL")=X ; SET VALUES IN LAB TBL 397 S ^TMP("C0CCCR","LABTBL",0)="V3" 398 Q 399 ; -
ccr/trunk/p/C0CMAIL.m
r1205 r1336 1 C0CMAIL 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 2 V ;;0.1;C0C;nopatch;noreleasedate 3 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research -
ccr/trunk/p/C0CMAIL2.m
r1331 r1336 1 C0CMAIL 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 2 V ;;0.1;C0C;nopatch;noreleasedate 3 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research -
ccr/trunk/p/C0CMAIL3.m
r1331 r1336 1 C0CMAIL 1 C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr 2 2 V ;;0.1;C0C;nopatch;noreleasedate 3 3 ;Copyright 2011 Chris Richardson, Richardson Computer Research -
ccr/trunk/p/C0CMCCD.m
r1185 r1336 1 C0CMCCD 1 C0CMCCD ; GPL - MXML based CCD utilities;12/04/09 17:05 2 2 ;;0.1;C0C;nopatch;noreleasedate 3 3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU … … 281 281 Q 282 282 ; 283 UPDIE 283 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 284 284 K ZERR 285 285 D CLEAN^DILF -
ccr/trunk/p/C0CMED.m
r1331 r1336 1 C0CMED 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 EXTRACT(MEDXML,DFN,MEDOUTXML) 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 RPMS 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 VISTA 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 ;;1.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 EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template 28 ; DFN passed by reference 29 ; MEDXML and MEDOUTXML are passed by Name 30 ; MEDXML is the input template 31 ; MEDOUTXML is the output template 32 ; Both of them refer to ^TMP globals where the XML documents are stored 33 ; 34 ; -- This ep is the driver for extracting medications into the provided XML template 35 ; 1. VA Outpatient Meds are in C0CMED1 36 ; 2. VA Pending Meds are in C0CMED2 37 ; 3. VA non-VA Meds are in C0CMED3 38 ; 4. VA Inpatient IV Meds are in C0CMED4 (not functional) 39 ; 5. VA Inpatient UD Meds are in C0CMED5 (doesn't exist yet)--March 2009 40 ; 6. RPMS Meds are in C0CMED6. Need to create other routines for subdivisions of RPMS Meds is not known at this time. 41 ; 42 ; --Get parameters for meds 43 S @MEDOUTXML@(0)=0 ; By default, empty. 44 N C0CMFLAG 45 S C0CMFLAG=$$GET^C0CPARMS("MEDALL")_"^"_$$GET^C0CPARMS("MEDLIMIT")_"^"_$$GET^C0CPARMS("MEDACTIVE")_"^"_$$GET^C0CPARMS("MEDPENDING") 46 W:$G(DEBUG) "Med Parameters: ",! 47 W:$G(DEBUG) "ALL: ",+C0CMFLAG,! 48 W:$G(DEBUG) "LIMIT: ",$P(C0CMFLAG,U,2),! 49 W:$G(DEBUG) "ACTIVE: ",$P(C0CMFLAG,U,3),! 50 W:$G(DEBUG) "PEND: ",$P(C0CMFLAG,U,4),! 51 ; --Find out what system we are on and branch out... 52 W:$G(DEBUG) "Agenecy: ",$G(DUZ("AG")) 53 I $$RPMS^C0CUTIL() D RPMS QUIT 54 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VISTA QUIT 55 RPMS 56 ;D EXTRACT^C0CMED6(MEDXML,DFN,MEDOUTXML,C0CMFLAG) QUIT 57 N MEDCOUNT S MEDCOUNT=0 58 K ^TMP($J,"MED") 59 N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed 60 N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds 61 S @HIST@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) 62 D EXTRACT^C0CMED6(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 63 D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 64 I @HIST@(0)>0 D 65 . D CP^C0CXPATH(HIST,MEDOUTXML) 66 . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! 67 I @NVA@(0)>0 D 68 . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,NVA) 69 . ;E D CP^C0CXPATH(NVA,MEDOUTXML) 70 . W:$G(DEBUG) "HAS NON-VA MEDS",! 71 Q 72 VISTA 73 N MEDCOUNT S MEDCOUNT=0 74 K ^TMP($J,"MED") 75 N HIST S HIST=$NA(^TMP($J,"MED","HIST")) ; Meds already dispensed 76 N PEND S PEND=$NA(^TMP($J,"MED","PEND")) ; Pending Meds 77 N NVA S NVA=$NA(^TMP($J,"MED","NVA")) ; non-VA Meds 78 K @HIST K @PEND K @NVA ; MAKE SURE THEY ARE EMPTY 79 S @HIST@(0)=0,@PEND@(0)=0,@NVA@(0)=0 ; At first, they are all empty... (prevent undefined errors) 80 ; N IPIV ; Inpatient IV Meds 81 N IPUD S IPUD=$NA(^TMP($J,"MED","IPUD")) ; Inpatient UD Meds 82 K @IPUD 83 S @IPUD@(0)=0 84 ; 85 D EXTRACT^C0CMED1(MEDXML,DFN,HIST,.MEDCOUNT,C0CMFLAG) ; Historical OP Meds 86 D:$P(C0CMFLAG,U,4) EXTRACT^C0CMED2(MEDXML,DFN,PEND,.MEDCOUNT) ; Pending Meds 87 ;D:+C0CMFLAG EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds 88 D EXTRACT^C0CMED3(MEDXML,DFN,NVA,.MEDCOUNT) ; non-VA Meds GPL 89 D EXTRACT^C0CNMED4(MEDXML,DFN,IPUD,.MEDCOUNT) ; inpatient gpl 90 I @HIST@(0)>0 D 91 . D CP^C0CXPATH(HIST,MEDOUTXML) 92 . W:$G(DEBUG) "HAS ACTIVE OP MEDS",! 93 I @PEND@(0)>0 D 94 . I @HIST@(0)>0 D INSINNER^C0CXPATH(MEDOUTXML,PEND) ;Add Pending to Historical 95 . E D CP^C0CXPATH(PEND,MEDOUTXML) ; No historical, just copy 96 . W:$G(DEBUG) "HAS OP PENDING MEDS",! 97 I @NVA@(0)>0 D 98 . I @HIST@(0)>0!(@PEND@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,NVA) 99 . E D CP^C0CXPATH(NVA,MEDOUTXML) 100 . W:$G(DEBUG) "HAS NON-VA MEDS",! 101 I @IPUD@(0)>0 D 102 . I @HIST@(0)>0!(@PEND@(0)>0)!(@NVA@(0)>0) D INSINNER^C0CXPATH(MEDOUTXML,IPUD) 103 . E D CP^C0CXPATH(IPUD,MEDOUTXML) 104 . W:$G(DEBUG) "HAS INPATIENT MEDS",! 105 N ZI 106 S ZI=$NA(^TMP("C0CCCR",$J,"MEDMAP")) 107 M ^TMP("C0CRIM","VARS",DFN,"MEDS")=@ZI ; PERSIST MEDS VARIABLES 108 K @ZI ; CLEAN UP MED MAP AFTER - GPL 10/10 109 K @PEND 110 K @HIST 111 K @NVA 112 K @IPUD 113 Q 114 -
ccr/trunk/p/C0CMED1.m
r1331 r1336 1 C0CMED1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 1 C0CMED1 ; WV/CCDCCR/SMH - CCR/CCD PROCESSING FOR MEDICATIONS ;01/10/09 2 ;;1.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 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT,FLAGS) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 25 ; 26 ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; INXML WILL CONTAIN ONLY THE MEDICATIONS SECTION OF THE OVERALL TEMPLATE 28 ; 29 ; MEDS is return array from RPC. 30 ; MAP is a mapping variable map (store result) for each med 31 ; MED is holds each array element from MEDS(J), one medicine 32 ; MEDCOUNT is a counter passed by Reference. 33 ; FLAGS are: MEDALL(bool)^MEDLIMIT(int)^MEDACTIVE(bool)^MEDPENDING(bool) 34 ; FLAGS are set-up in C0CMED. 35 ; 36 ; RX^PSO52API is a Pharmacy Re-Enginnering (PRE) API to get all 37 ; med data available. 38 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf 39 ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). 40 ; D PARY^C0CXPATH(MINXML) 41 N MEDS,MAP 42 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 43 N ALL S ALL=+FLAGS 44 N ACTIVE S ACTIVE=$P(FLAGS,U,3) 45 ; Below, X1 is today; X2 is the number of days we want to go back 46 ; X is the result of this calculation using C^%DTC. 47 N X,X1,X2 48 S X1=DT 49 S X2=-$P($P(FLAGS,U,2),"-",2) 50 D C^%DTC 51 ; I discovered that I shouldn't put an ending date (last parameter) 52 ; because it seems that it will get meds whose beginning is after X but 53 ; whose exipriation is before the ending date. 54 D RX^PSO52API(DFN,"CCDCCR","","","",X,"") 55 M MEDS=^TMP($J,"CCDCCR",DFN) 56 ; @(0) contains the number of meds or -1^NO DATA FOUND 57 ; If it is -1, we quit. 58 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 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
r1331 r1336 1 C0CMED2 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 1 C0CMED2 ; WV/CCDCCR/SMH - CCR/CCD Meds - Pending for Vista 2 ;;1.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 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMPLATE 25 ; 26 ; MINXML is the Input XML Template, passed by name 27 ; DFN is Patient IEN (by Value) 28 ; OUTXML is the resultant XML (by Name) 29 ; MEDCOUNT is the current count of extracted meds, passed by Reference 30 ; 31 ; MEDS is return array from RPC. 32 ; MAP is a mapping variable map (store result) for each med 33 ; MED is holds each array element from MEDS, one medicine 34 ; 35 ; PEN^PSO5241 is a Pharmacy Re-Enginnering (PRE) API to get Pending 36 ; meds data available. 37 ; http://www.va.gov/vdl/documents/Clinical/Pharm-Outpatient_Pharmacy/phar_1_api_r0807.pdf 38 ; Output of API is ^TMP($J,"SUBSCRIPT",DFN,RXIENS). 39 ; File for pending meds is 52.41 40 ; Unfortuantely, API does not supply us with any useful info beyond 41 ; the IEN in 52.41, and the Med Name, and route. 42 ; So, most of the info is going to get pulled from 52.41. 43 N MEDS,MAP 44 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 45 D PEN^PSO5241(DFN,"CCDCCR") 46 M MEDS=^TMP($J,"CCDCCR",DFN) 47 ; @(0) contains the number of meds or -1^NO DATA FOUND 48 ; If it is -1, we quit. 49 I $P(MEDS(0),U)=-1 S @OUTXML@(0)=0 QUIT 50 ZWRITE:$G(DEBUG) MEDS 51 N RXIEN S RXIEN=0 52 N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED IN THIS SECTION FOR MERGING 53 F S RXIEN=$O(MEDS(RXIEN)) Q:RXIEN="B" D ; FOR EACH MEDICATION IN THE LIST 54 . I $$GET1^DIQ(52.41,RXIEN,2,"I")="RF" QUIT ; Dont' want refill request as a "pending" order 55 . S MEDCOUNT=MEDCOUNT+1 56 . I DEBUG W "RXIEN IS ",RXIEN,! 57 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 58 . ; K @MAP DON'T KILL MAP HERE, IT IS DONE IN C0CMED 59 . I DEBUG W "MAP= ",MAP,! 60 . N MED M MED=MEDS(RXIEN) ; PULL OUT MEDICATION FROM 61 . S @MAP@("MEDOBJECTID")="MED_PENDING"_MEDCOUNT ; MEDCOUNT FOR ID 62 . ; S @MAP@("MEDOBJECTID")="MED_PENDING"_MED(.01) ;Pending IEN 63 . S @MAP@("MEDISSUEDATETXT")="Issue Date" 64 . ; Field 6 is "Effective date", and we pull it in timson format w/ I 65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL($$GET1^DIQ(52.41,RXIEN,6,"I"),"DT") 66 . ; Med never filled; next 4 fields are not applicable. 67 . S @MAP@("MEDLASTFILLDATETXT")="" 68 . S @MAP@("MEDLASTFILLDATE")="" 69 . S @MAP@("MEDRXNOTXT")="" 70 . S @MAP@("MEDRXNO")="" 71 . S @MAP@("MEDTYPETEXT")="Medication" 72 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 73 . S @MAP@("MEDSTATUSTEXT")="On Hold" ; nearest status for pending meds 74 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$$GET1^DIQ(52.41,RXIEN,5,"I") 75 . S @MAP@("MEDPRODUCTNAMETEXT")=$P(MED(11),U,2) 76 . ; NDC not supplied in API, but is rather trivial to obtain 77 . ; MED(11) piece 1 has the IEN of the drug (file 50) 78 . ; IEN is field 31 in the drug file. 79 . ; 80 . ; MEDIEN (node 11 in the returned output) might not necessarily be defined 81 . ; It is not defined when a dose in not chosen in CPRS. There is a long 82 . ; series of fields that depend on it. We will use If and Else to deal 83 . ; with that 84 . N MEDIEN S MEDIEN=$P(MED(11),U) 85 . I +MEDIEN>0 D ; start of if/else block 86 . . ; 12/30/08: I will be using RxNorm for coding... 87 . . ; 176.001 is the file for Concepts; 176.003 is the file for 88 . . ; sources (i.e. for RxNorm Version) 89 . . ; 90 . . ; We need the VUID first for the National Drug File entry first 91 . . ; We get the VUID of the drug, by looking up the VA Product entry 92 . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. 93 . . ; Field 99.99 is the VUID. 94 . . ; 95 . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. 96 . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by 97 . . ; $$GET1^DIQ. 98 . . ; 99 . . ; I get the RxNorm name and version from the RxNorm Sources (file 100 . . ; 176.003), by searching for "RXNORM", then get the data. 101 . . D NDF^PSS50(MEDIEN,,,,,"NDF") 102 . . N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) 103 . . N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 104 . . N VAPROD S VAPROD=$P(NDFDATA(22),U) 105 . . ; 106 . . ; NDFIEN is not necessarily defined; it won't be if the drug 107 . . ; is not matched to the national drug file (e.g. if the drug is 108 . . ; new on the market, compounded, or is a fake drug [blue pill]. 109 . . ; To protect against failure, I will put an if/else block 110 . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER 111 . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 112 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 113 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 114 . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 115 . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 116 . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 117 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 118 . . ; 119 . . E S (RXNORM,RXNNAME,RXNVER)="" 120 . . ; End if/else block 121 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 122 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 123 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 124 . . ; 125 . . S @MAP@("MEDBRANDNAMETEXT")="" 126 . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 127 . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 128 . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 129 . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 130 . . ; Units, concentration, etc, come from another call 131 . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 132 . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 133 . . ; NDF Entry IEN, and VA Product Name 134 . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 135 . . ; Documented in the same manual; executed above. 136 . . N CONCDATA 137 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 138 . . ; and this will crash the call. So... 139 . . I NDFIEN="" S CONCDATA="" 140 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 141 . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 142 . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 143 . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 144 . . S @MAP@("MEDQUANTITYVALUE")=$$GET1^DIQ(52.41,RXIEN,12) 145 . . ; Oddly, there is no easy place to find the dispense unit. 146 . . ; It's not included in the original call, so we have to go to the drug file. 147 . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 148 . . ; Node 14.5 is the Dispense Unit 149 . . D DATA^PSS50(MEDIEN,,,,,"QTY") 150 . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 151 . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 152 . E D 153 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" 154 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 155 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" 156 . . S @MAP@("MEDBRANDNAMETEXT")="" 157 . . S @MAP@("MEDSTRENGTHVALUE")="" 158 . . S @MAP@("MEDSTRENGTHUNIT")="" 159 . . S @MAP@("MEDFORMTEXT")="" 160 . . S @MAP@("MEDCONCVALUE")="" 161 . . S @MAP@("MEDCONCUNIT")="" 162 . . S @MAP@("MEDSIZETEXT")="" 163 . . S @MAP@("MEDQUANTITYVALUE")="" 164 . . S @MAP@("MEDQUANTITYUNIT")="" 165 . ; end of if/else block 166 . ; 167 . ; --- START OF DIRECTIONS --- 168 . ; Sig data is not in any API. We obtain it using the IEN from 169 . ; the PEN API to file 52.41. It's in field 3, which is a multiple. 170 . ; I will be using FM call GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT) 171 . K FMSIG ; it's passed via the symbol table, so remove any leftovers from last call 172 . D GETS^DIQ(52.41,RXIEN,"3*",,"FMSIG") 173 . N FMSIGNUM S FMSIGNUM=0 ; Sigline number in fileman. 174 . ; FMSIGNUM gets outputted as "IEN,RXIEN,". 175 . ; DIRNUM will be first piece for IEN. 176 . ; DIRNUM is the proper Sigline numer. 177 . ; SIGDATA is the simplfied array. Subscripts are really field numbers 178 . ; in subfile 52.413. 179 . N DIRCNT S DIRCNT=0 ; COUNT OF DIRECTIONS 180 . F S FMSIGNUM=$O(FMSIG(52.413,FMSIGNUM)) Q:FMSIGNUM="" D 181 . . N DIRNUM S DIRNUM=$P(FMSIGNUM,",") 182 . . S DIRCNT=DIRCNT+1 ; INCREMENT DIRECTIONS COUNT 183 . . N SIGDATA M SIGDATA=FMSIG(52.413,FMSIGNUM) 184 . . ; If this is an order for a refill; it's not really a new order; move on to next 185 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONDESCRIPTIONTEXT")="" ; This is reserved for systems not able to generate the sig in components. 186 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEINDICATOR")="1" ; means that we are specifying it. See E2369-05. 187 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDELIVERYMETHOD")=SIGDATA(13) 188 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEVALUE")=SIGDATA(8) 189 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDOSEUNIT")=@MAP@("MEDCONCUNIT") 190 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEVALUE")="" ; For inpatient 191 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDRATEUNIT")="" ; For inpatient 192 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDVEHICLETEXT")="" ; For inpatient 193 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRECTIONROUTETEXT")=SIGDATA(10) 194 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDFREQUENCYVALUE")=SIGDATA(1) 195 . . ; Invervals... again another call. 196 . . ; The schedule is a free text field 197 . . ; However, it gets translated by a call to the administration 198 . . ; schedule file to see if that schedule exists. 199 . . ; That's the same thing I am going to do. 200 . . ; The call is AP^PSS51P1(PSSPP,PSSFT,PSSWDIEN,PSSSTPY,LIST,PSSFREQ). 201 . . ; PSSPP is "PSJ" (for some reason, schedules are stored as PSJ, not PSO-- 202 . . ; I looked), PSSFT is the name, 203 . . ; and list is the ^TMP name to store the data in. 204 . . ; Also, freqency may have "PRN" in it, so strip that out 205 . . N FREQ S FREQ=SIGDATA(1) 206 . . I FREQ["PRN" S FREQ=$E(FREQ,1,$F(FREQ,"PRN")-5) ; 5 for $L("PRN") + 1 + sp 207 . . D AP^PSS51P1("PSJ",FREQ,,,"SCHEDULE") 208 . . N SCHEDATA M SCHEDATA=^TMP($J,"SCHEDULE") 209 . . N INTERVAL 210 . . I $P(SCHEDATA(0),U)=-1 S INTERVAL="" 211 . . E D 212 . . . N SUB S SUB=$O(SCHEDATA(0)) 213 . . . S INTERVAL=SCHEDATA(SUB,2) 214 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALVALUE")=INTERVAL 215 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDINTERVALUNIT")="Minute" 216 . . ; Duration comes as M2,H2,D2,W2,L2 for 2 minutes,hours,days,weeks,months 217 . . N DUR S DUR=SIGDATA(2) 218 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONVALUE")=$E(DUR,2,$L(DUR)) 219 . . N DURUNIT S DURUNIT=$E(DUR) 220 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDURATIONUNIT")=$S(DURUNIT="M":"Minutes",DURUNIT="H":"Hours",DURUNIT="D":"Days",DURUNIT="W":"Weeks",DURUNIT="L":"Months",1:"") 221 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPRNFLAG")=SIGDATA(1)["PRN" 222 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMOBJECTID")="" 223 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMTYPETXT")="" 224 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMDESCRIPTION")="" 225 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODEVALUE")="" 226 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGSYSTEM")="" 227 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMCODINGVERSION")="" 228 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDPROBLEMSOURCEACTORID")="" 229 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDSTOPINDICATOR")="" ; Vista doesn't have that field 230 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDDIRSEQ")=DIRNUM 231 . . S @MAP@("M","DIRECTIONS",DIRCNT,"MEDMULDIRMOD")=SIGDATA(6) 232 . ; 233 . ; --- END OF DIRECTIONS --- 234 . ; 235 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 236 . S @MAP@("MEDPTINSTRUCTIONS")=$G(^PSRX(RXIEN,"PI",1,0)) ;GPL 237 . ; W @MAP@("MEDPTINSTRUCTIONS"),! 238 . ; S @MAP@("MEDFULLFILLMENTINSTRUCTIONS","F")="52.41^9" 239 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=$G(^PSRX(RXIEN,"SIG1",1,0)) ;GPL 240 . ; W @MAP@("MEDFULLFILLMENTINSTRUCTIONS"),! 241 . S @MAP@("MEDRFNO")=$$GET1^DIQ(52.41,RXIEN,13) 242 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 243 . K @RESULT 244 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 245 . ; D PARY^C0CXPATH(RESULT) 246 . ; MAPPING DIRECTIONS 247 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 248 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 249 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 250 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 251 . ; N MDZ1,MDZNA 252 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 253 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 254 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 255 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 256 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 257 . I MEDFIRST D ; 258 . . S MEDFIRST=0 ; RESET FIRST FLAG 259 . . D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 260 . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER 261 N MEDTMP,MEDI 262 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 263 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 264 . W "Pending Medication MISSING ",! 265 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 266 Q 267 ; -
ccr/trunk/p/C0CMED3.m
r1331 r1336 1 C0CMED3 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 1 C0CMED3 ; WV/CCDCCR/SMH - Meds: Non-VA/Outside Meds for Vista 2 ;;1.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 EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml template 25 ; 26 ; MINXML is the Input XML Template, (passed by name) 27 ; DFN is Patient IEN (passed by value) 28 ; OUTXML is the resultant XML (passed by name) 29 ; MEDCOUNT is the number of Meds extracted so far (passed by reference) 30 ; 31 ; MEDS is return array from RPC. 32 ; MAP is a mapping variable map (store result) for each med 33 ; MED is holds each array element from MEDS, one medicine 34 ; 35 ; Non-VA meds don't have an API. They are stored in file 55, subfile 52.2 36 ; Discontinued meds are indicated by the presence of a value in fields 37 ; 5 or 6 (STATUS 1 or 2, and DISCONTINUED DATE) 38 ; Will use Fileman API GETS^DIQ 39 ; 40 N MEDS,MAP 41 K ^TMP($J,"CCDCCR") ; PLEASE DON'T KILL ALL OF ^TMP($J) HERE!!!! 42 N NVA 43 D GETS^DIQ(55,DFN,"52.2*","IE","NVA") ; Output in NVA in FDA array format. 44 ; If NVA does not exist, then patient has no non-VA meds 45 I $D(NVA)=0 S @OUTXML@(0)=0 QUIT 46 ; Otherwise, we go on... 47 M MEDS=NVA(55.05) 48 ; We are done with NVA 49 K NVA 50 ; 51 I DEBUG ZWRITE MEDS 52 N FDAIEN S FDAIEN=0 ; For use in $Order in the MEDS array. 53 N MEDFIRST S MEDFIRST=1 ; FLAG FOR FIRST MED PROCESSED HERE 54 F S FDAIEN=$O(MEDS(FDAIEN)) Q:FDAIEN="" D ; FOR EACH MEDICATION IN THE LIST 55 . N MED M MED=MEDS(FDAIEN) 56 . I MED(5,"I")!MED(6,"I") QUIT ; If disconinued, we don't want to pull it. 57 . S MEDCOUNT=MEDCOUNT+1 58 . S MAP=$NA(^TMP("C0CCCR",$J,"MEDMAP",MEDCOUNT)) 59 . N RXIEN S RXIEN=$P(FDAIEN,",") ; First piece of FDAIEN is the number of the med for this patient 60 . I DEBUG W "RXIEN IS ",RXIEN,! 61 . I DEBUG W "MAP= ",MAP,! 62 . S @MAP@("MEDOBJECTID")="MED_OUTSIDE"_MEDCOUNT ; MEDCOUNT FOR ID 63 . S @MAP@("MEDISSUEDATETXT")="Documented Date" 64 . ; Field 6 is "Effective date", and we pull it in timson format w/ I 65 . S @MAP@("MEDISSUEDATE")=$$FMDTOUTC^C0CUTIL(MED(11,"I"),"DT") 66 . ; Med never filled; next 4 fields are not applicable. 67 . S @MAP@("MEDLASTFILLDATETXT")="" 68 . S @MAP@("MEDLASTFILLDATE")="" 69 . S @MAP@("MEDRXNOTXT")="" 70 . S @MAP@("MEDRXNO")="" 71 . S @MAP@("MEDTYPETEXT")="Medication" 72 . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses 73 . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds 74 . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") 75 . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") 76 . ; NDC is field 31 in the drug file. 77 . ; The actual drug entry in the drug file (MEDIEN) is not necessarily supplied. 78 . ; It' node 1, internal form. 79 . N MEDIEN S MEDIEN=MED(1,"I") 80 . I +MEDIEN D ; start of if/else block 81 . . ; 12/30/08: I will be using RxNorm for coding... 82 . . ; 176.001 is the file for Concepts; 176.003 is the file for 83 . . ; sources (i.e. for RxNorm Version) 84 . . ; 85 . . ; We need the VUID first for the National Drug File entry first 86 . . ; We get the VUID of the drug, by looking up the VA Product entry 87 . . ; (file 50.68) using the call NDF^PSS50, returned in node 22. 88 . . ; Field 99.99 is the VUID. 89 . . ; 90 . . ; We use the VUID to look up the RxNorm in file 176.001; same idea. 91 . . ; Get IEN first using $$FIND1^DIC, then get the RxNorm number by 92 . . ; $$GET1^DIQ. 93 . . ; 94 . . ; I get the RxNorm name and version from the RxNorm Sources (file 95 . . ; 176.003), by searching for "RXNORM", then get the data. 96 . . ; NDF^PSS50 ONLY EXISTS ON VISTA 97 . . N NDFDATA,NDFIEN,VAPROD 98 . . S NDFIEN="" 99 . . I '$$RPMS^C0CUTIL() D 100 . . . D NDF^PSS50(MEDIEN,,,,,"NDF") 101 . . . ;N NDFDATA M NDFDATA=^TMP($J,"NDF",MEDIEN) 102 . . . ;N NDFIEN S NDFIEN=$P(NDFDATA(20),U) 103 . . . ;N VAPROD S VAPROD=$P(NDFDATA(22),U) 104 . . . M NDFDATA=^TMP($J,"NDF",MEDIEN) 105 . . . S NDFIEN=$P(NDFDATA(20),U) 106 . . . S VAPROD=$P(NDFDATA(22),U) 107 . . . S @MAP@("MEDPRODUCTNAMETEXT")=$$GET1^DIQ(50.68,VAPROD,.01) ; 108 . . ; GPL - RESET THE NAME TO THE REAL NAME OF THE DRUG NOW THAT WE 109 . . ; HAVE IT. 110 . . ; 111 . . ; NDFIEN is not necessarily defined; it won't be if the drug 112 . . ; is not matched to the national drug file (e.g. if the drug is 113 . . ; new on the market, compounded, or is a fake drug [blue pill]. 114 . . ; To protect against failure, I will put an if/else block 115 . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER 116 . . ; 117 . . ; begin changes for systems that have eRx installed 118 . . ; RxNorm is found in the ^C0P("RXN") global - gpl 119 . . ; 120 . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION 121 . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE 122 . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE 123 . . I NDFIEN,$D(^C0P("RXN")) D ; 124 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 125 . . . S ZC=$$CODE^C0CUTIL(VUID) 126 . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE 127 . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID 128 . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION 129 . . . S RXNORM=ZCD ; THE CODE 130 . . . S RXNNAME=ZCDS ; THE CODING SYSTEM 131 . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION 132 . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") 133 . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD 134 . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. 135 . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) 136 . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") 137 . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) 138 . . . S SRCIEN=$$FIND1^DIC(176.003,,"B","RXNORM") 139 . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) 140 . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) 141 . . ; 142 . . ;E S (RXNORM,RXNNAME,RXNVER)="" 143 . . ; End if/else block 144 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 145 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 146 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 147 . . ; 148 . . S @MAP@("MEDBRANDNAMETEXT")="" 149 . . ; DOSE^PSS50 ONLY ESISTS ON VISTA 150 . . I '$$RPMS^C0CUTIL() D 151 . . . D DOSE^PSS50(MEDIEN,,,,,"DOSE") 152 . . . N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) 153 . . . S @MAP@("MEDSTRENGTHVALUE")=DOSEDATA(901) 154 . . . S @MAP@("MEDSTRENGTHUNIT")=$P(DOSEDATA(902),U,2) 155 . . E S @MAP@("MEDSTRENGTHVALUE")="" S @MAP@("MEDSTRENGTHUNIT")="" 156 . . ; Units, concentration, etc, come from another call 157 . . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit 158 . . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters 159 . . ; NDF Entry IEN, and VA Product Name 160 . . ; These can be obtained using NDF^PSS50 (IEN,,,,,"SUBSCRIPT") 161 . . ; Documented in the same manual; executed above. 162 . . ; 163 . . ; If a drug was not matched to NDF, then the NDFIEN is gonna be "" 164 . . ; and this will crash the call. So... 165 . . I NDFIEN="" S CONCDATA="" 166 . . E S CONCDATA=$$CPRS^PSNAPIS(NDFIEN,VAPROD) 167 . . S @MAP@("MEDFORMTEXT")=$P(CONCDATA,U,1) 168 . . S @MAP@("MEDCONCVALUE")=$P(CONCDATA,U,3) 169 . . S @MAP@("MEDCONCUNIT")=$P(CONCDATA,U,4) 170 . . S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. 171 . . ; Oddly, there is no easy place to find the dispense unit. 172 . . ; It's not included in the original call, so we have to go to the drug file. 173 . . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") 174 . . ; Node 14.5 is the Dispense Unit 175 . . ; PSS50 ONLY EXISTS ON VISTA 176 . . I '$$RPMS^C0CUTIL() D 177 . . . D DATA^PSS50(MEDIEN,,,,,"QTY") 178 . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) 179 . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) 180 . . E S @MAP@("MEDQUANTITYUNIT")="" 181 . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these 182 . E D 183 . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" 184 . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" 185 . . S @MAP@("MEDPRODUCTNAMECODEVERSION")="" 186 . . S @MAP@("MEDBRANDNAMETEXT")="" 187 . . S @MAP@("MEDSTRENGTHVALUE")="" 188 . . S @MAP@("MEDSTRENGTHUNIT")="" 189 . . S @MAP@("MEDFORMTEXT")="" 190 . . S @MAP@("MEDCONCVALUE")="" 191 . . S @MAP@("MEDCONCUNIT")="" 192 . . S @MAP@("MEDSIZETEXT")="" 193 . . S @MAP@("MEDQUANTITYVALUE")="" 194 . . S @MAP@("MEDQUANTITYUNIT")="" 195 . ; End If/Else 196 . ; --- START OF DIRECTIONS --- 197 . ; Dosage is field 2, route is 3, schedule is 4 198 . ; These are all free text fields, and don't point to any files 199 . ; For that reason, I will use the field I never used before: 200 . ; MEDDIRECTIONDESCRIPTIONTEXT 201 . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS 202 . ; 203 . ; change for eRx meds - gpl 6/25/2011 204 . ; 205 . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 206 . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME 207 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX 208 . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity 209 . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME 210 . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME 211 . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME 212 . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM 213 . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY 214 . . I RXNORM'="" D ; 215 . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM 216 . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM 217 . . . S RXNVER="" ; THE CODING SYSTEM VERSION 218 . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") 219 . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM 220 . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM 221 . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME 222 . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER 223 . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION 224 . . . . S @MAP@("MEDSTRENGTHVALUE")=650 225 . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" 226 . . . . S @MAP@("MEDFORMTEXT")="INHALER" 227 . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS 228 . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY 229 . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; 230 . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") 231 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. 232 . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" 233 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" 234 . S @MAP@("M","DIRECTIONS",1,"MEDDOSEUNIT")="" 235 . S @MAP@("M","DIRECTIONS",1,"MEDRATEVALUE")="" 236 . S @MAP@("M","DIRECTIONS",1,"MEDRATEUNIT")="" 237 . S @MAP@("M","DIRECTIONS",1,"MEDVEHICLETEXT")="" 238 . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONROUTETEXT")="" 239 . S @MAP@("M","DIRECTIONS",1,"MEDFREQUENCYVALUE")="" 240 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALVALUE")="" 241 . S @MAP@("M","DIRECTIONS",1,"MEDINTERVALUNIT")="" 242 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONVALUE")="" 243 . S @MAP@("M","DIRECTIONS",1,"MEDDURATIONUNIT")="" 244 . S @MAP@("M","DIRECTIONS",1,"MEDPRNFLAG")="" 245 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMOBJECTID")="" 246 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMTYPETXT")="" 247 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMDESCRIPTION")="" 248 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODEVALUE")="" 249 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGSYSTEM")="" 250 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMCODINGVERSION")="" 251 . S @MAP@("M","DIRECTIONS",1,"MEDPROBLEMSOURCEACTORID")="" 252 . S @MAP@("M","DIRECTIONS",1,"MEDSTOPINDICATOR")="" 253 . S @MAP@("M","DIRECTIONS",1,"MEDDIRSEQ")="" 254 . S @MAP@("M","DIRECTIONS",1,"MEDMULDIRMOD")="" 255 . ; 256 . ; --- END OF DIRECTIONS --- 257 . ; 258 . S @MAP@("MEDRFNO")="" 259 . I $D(MED(14,1)) D ; 260 . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field 261 . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" 262 . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl 263 . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) 264 . K @RESULT 265 . D MAP^C0CXPATH(MINXML,MAP,RESULT) 266 . ; D PARY^C0CXPATH(RESULT) 267 . ; MAPPING DIRECTIONS 268 . N MEDDIR1,DIRXML1 S DIRXML1="MEDDIR1" ; VARIABLE AND NAME VARIABLE TEMPLATE 269 . N MEDDIR2,DIRXML2 S DIRXML2="MEDDIR2" ; VARIABLE AND NAME VARIABLE RESULT 270 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/Directions",DIRXML1) 271 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/Directions") 272 . N MDZ1,MDZNA 273 . I DIRCNT>0 D ; IF THERE ARE DIRCTIONS 274 . . F MDZ1=1:1:DIRCNT D ; FOR EACH DIRECTION 275 . . . S MDZNA=$NA(@MAP@("M","DIRECTIONS",MDZ1)) 276 . . . D MAP^C0CXPATH(DIRXML1,MDZNA,DIRXML2) 277 . . . D INSERT^C0CXPATH(RESULT,DIRXML2,"//Medications/Medication") 278 . ; 279 . ; MAP PATIENT INSTRUCTIONS - HAVE TO DO THIS AFTER MAPPING DIRECTIONS DUE TO XML SCHEMA VALIDATION 280 . N MEDINT1,INTXML1 S INTXML1="MENINT1" ; VARIABLE AND NAME VARIABLE TEMPLATE 281 . N MEDINT2,INTXML2 S INTXML2="MEDINT2" ; VARIABLE AND NAME VARIABLE RESULT 282 . D QUERY^C0CXPATH(MINXML,"//Medications/Medication/PatientInstructions",INTXML1) 283 . D REPLACE^C0CXPATH(RESULT,"","//Medications/Medication/PatientInstructions") 284 . ;N MDI1 ; removing the "I" which is not in the protocol gpl 1/2010 285 . ;S MDI1=$NA(@MAP@("I")) 286 . ; S @MAP@("MEDPTINSTRUCTIONS","F")="52.41^105" 287 . I $D(MED(10,1)) D ; 288 . . ;S @MAP@("I","MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 289 . . S @MAP@("MEDPTINSTRUCTIONS")=$P(MED(10,1)," ",1) ; WP Field 290 . E S @MAP@("MEDPTINSTRUCTIONS")="" 291 . ;E S @MAP@("I","MEDPTINSTRUCTIONS")="" 292 . ;D MAP^C0CXPATH(INTXML1,MDI1,INTXML2) 293 . D MAP^C0CXPATH(INTXML1,MAP,INTXML2) ; JUST MAP WORKS.. GPL 294 . D INSERT^C0CXPATH(RESULT,INTXML2,"//Medications/Medication") 295 . ; 296 . ; FLAG HAS TO BE RESET OUTSIDE THE IF STATMENT. 297 . ;I MEDFIRST D ; 298 . ;. S MEDFIRST=0 ; RESET FIRST FLAG 299 . ;. D CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 300 . ;D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER FIRST, INSERT INNER XML 301 . D:MEDFIRST CP^C0CXPATH(RESULT,OUTXML) ; First one is a copy 302 . D:'MEDFIRST INSINNER^C0CXPATH(OUTXML,RESULT) ; AFTER THE FIRST, INSERT INNER XML 303 . I MEDFIRST S MEDFIRST=0 304 N MEDTMP,MEDI 305 D MISSING^C0CXPATH(OUTXML,"MEDTMP") ; SEARCH XML FOR MISSING VARS 306 I MEDTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 307 . W "MEDICATION MISSING ",! 308 . F MEDI=1:1:MEDTMP(0) W MEDTMP(MEDI),! 309 Q 310 ; -
ccr/trunk/p/C0CMED6.m
r691 r1336 165 165 . ; we want the components. 166 166 . ; It's in multiple 113 in the Prescription File (52) 167 . ; #.01 DOSAGE ORDERED [1F] 168 . ; #1 DISPENSE UNITS PER DOSE [2N] 169 . ; #2 UNITS [3P:50.607] 170 . ; #3 NOUN [4F] 171 . ; #4 DURATION [5F] 172 . ; #5 CONJUNCTION [6S] 173 . ; #6 ROUTE [7P:51.2] 174 . ; #7 SCHEDULE [8F] 175 . ; #8 VERB [9F] 167 . ; #.01 DOSAGE ORDERED [1F] "20" 168 . ; #1 DISPENSE UNITS PER DOSE [2N] "1" 169 . ; #2 UNITS [3P:50.607] "MG" 170 . ; #3 NOUN [4F] "TABLET" 171 . ; #4 DURATION [5F] "10D" 172 . ; #5 CONJUNCTION [6S] "AND" 173 . ; #6 ROUTE [7P:51.2] "ORAL" 174 . ; #7 SCHEDULE [8F] "BID" 175 . ; #8 VERB [9F] "TAKE" 176 176 . ; 177 177 . ; Will use GETS^DIQ to get fields. … … 306 306 Q 307 307 ; 308 GETRXN(NDC) 308 GETRXN(NDC) ; Extrinsic Function; PUBLIC; NDC to RxNorm 309 309 ;; Get RxNorm Concept Number for a Given NDC 310 310 ; -
ccr/trunk/p/C0CMXML.m
r1331 r1336 1 C0CMXML 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 TEST 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 TEST2 43 44 45 46 47 TEST3 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 TEST3A 72 73 74 75 76 77 78 79 80 TESTQ 81 82 83 84 85 86 87 88 89 90 91 92 93 TESTQ2 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 TEST4 110 111 112 113 114 115 116 117 118 119 TEST5 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 PARSE(INXML,INDOC) 177 178 179 180 181 182 ISMULT(ZOID) 183 184 185 186 187 188 189 FIRST(ZOID) 190 191 192 PARENT(ZOID) 193 194 195 ATT(RTN,NODE) 196 197 198 199 200 201 TAG(ZOID) 202 203 204 205 206 207 208 209 210 NXTSIB(ZOID) 211 212 213 DATA(ZT,ZOID) 214 215 216 217 218 219 220 OUTXML(ZRTN,INID) 221 222 223 224 225 226 227 228 229 230 NDOUT(ZOID) 231 232 233 234 235 236 237 238 239 240 241 242 243 244 UPDIE 245 246 247 248 249 250 251 252 253 254 1 C0CMXML ; GPL - MXML based XPath utilities;10/13/09 17:05 2 ;;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/C0CMXP.m
r1331 r1336 1 C0CMXP 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 INITXPF(ARY) 23 24 25 26 27 28 29 30 31 32 33 SETXPF(ARY) 34 35 36 37 38 39 40 41 42 ADDXP(INARY,TID,FARY) 43 44 45 46 47 48 49 50 51 52 53 54 55 FIXICD9 56 57 58 59 60 61 62 63 64 ADDXML(INXML,TEMPID,INFARY) 65 66 67 68 69 70 71 72 73 74 ADDTEMP(INXML,TEMPID,INFARY) 75 76 77 78 79 80 81 82 83 84 GETXML(OUTXML,TEMPID,INFARY) 85 86 87 88 89 90 91 92 93 94 95 GETTEMP(OUTXML,TEMPID,FARY) 96 97 98 99 100 101 102 103 104 105 106 COPYWP(ZFLD,ZSRCREC,ZDESTREC,ZSRCF,ZDESTF) 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 COMPILE(TID,UFARY) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 MKTPLATE(OUTT,OUTIDX,INXML,REDUX) 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 INVERT(OUTX,INX) 190 191 192 193 194 195 196 DEMUX(OUTX,INX) 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 DEMUXARY(OARY,IARY,DEPTH) 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 DEMUX2(OARY,IARY,DEPTH) 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 DEMUXXP1(OARY,IARY) 249 250 251 252 253 254 255 256 257 258 259 260 261 262 DEMUXXP2(OARY,IARY) 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 UPDIE 283 284 285 286 287 288 289 290 291 292 1 C0CMXP ; GPL - MXML based XPath utilities;12/04/09 17:05 2 ;;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 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 283 K ZERR 284 D CLEAN^DILF 285 D UPDATE^DIE("","C0CFDA","","ZERR") 286 I $D(ZERR) D ; 287 . W "ERROR",! 288 . ZWR ZERR 289 . B 290 K C0CFDA 291 Q 292 ; -
ccr/trunk/p/C0CNHIN.m
r1204 r1336 1 C0CNHIN 1 C0CNHIN ; GPL - PROCESSING FOR OUTPUT OF NHINV ROUTINES;6/3/11 17:05 2 2 ;;0.1;C0C;nopatch;noreleasedate;Build 38 3 3 ;Copyright 2011 George Lilly. Licensed under the terms of the GNU … … 146 146 Q 147 147 ; 148 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) 148 DOMO(ZOID,ZPATH,ZNARY,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE 149 149 ; THE XPATH INDEX ZXIDX, PASSED BY NAME 150 150 ; THE XPATH ARRAY XPARY, PASSED BY NAME … … 205 205 Q 206 206 ; 207 PARSE(INXML,INDOC) 207 PARSE(INXML,INDOC) ;CALL THE MXML PARSER ON INXML, PASSED BY NAME 208 208 ; INDOC IS PASSED AS THE DOCUMENT NAME - DON'T KNOW WHERE TO STORE THIS NOW 209 209 ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY MXML … … 211 211 Q $$EN^MXMLDOM(INXML,"W") 212 212 ; 213 ISMULT(ZOID) 213 ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE 214 214 N ZN 215 215 ;I $$TAG(ZOID)["entry" B … … 218 218 Q 0 219 219 ; 220 FIRST(ZOID) 220 FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID 221 221 Q $$CHILD^MXMLDOM(C0CDOCID,ZOID) 222 222 ; 223 PARENT(ZOID) 223 PARENT(ZOID) ;RETURNS THE OID OF THE PARENT OF ZOID 224 224 Q $$PARENT^MXMLDOM(C0CDOCID,ZOID) 225 225 ; 226 ATT(RTN,NODE) 226 ATT(RTN,NODE) ;GET ATTRIBUTES FOR ZOID 227 227 S HANDLE=C0CDOCID 228 228 K @RTN … … 230 230 Q 231 231 ; 232 TAG(ZOID) 232 TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE 233 233 ;I ZOID=149 B ;GPLTEST 234 234 N X,Y … … 239 239 Q Y 240 240 ; 241 NXTSIB(ZOID) 241 NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING 242 242 Q $$SIBLING^MXMLDOM(C0CDOCID,ZOID) 243 243 ; 244 DATA(ZT,ZOID) 244 DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE 245 245 ;N ZT,ZN S ZT="" 246 246 ;S C0CDOM=$NA(^TMP("MXMLDOM",$J,C0CDOCID)) … … 249 249 Q 250 250 ; 251 OUTXML(ZRTN,INID) 251 OUTXML(ZRTN,INID) ; USES C0CMXMLB (MXMLBLD) TO OUTPUT XML FROM AN MXMLDOM 252 252 ; 253 253 S C0CDOCID=INID … … 259 259 Q 260 260 ; 261 NDOUT(ZOID) 261 NDOUT(ZOID) ;CALLBACK ROUTINE - IT IS RECURSIVE 262 262 N ZI S ZI=$$FIRST(ZOID) 263 263 I ZI'=0 D ; THERE IS A CHILD -
ccr/trunk/p/C0CNMED2.m
r1205 r1336 1 C0CMED 1 C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 2 2 ;;1.0;C0C;;May 19, 2009;Build 38 3 3 ; Copyright 2008,2009 George Lilly, University of Minnesota and Sam Habiel. -
ccr/trunk/p/C0CORSLT.m
r1331 r1336 1 1 C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 2 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;;Jan 21, 2010;Build 38 3 ;Copyright 2011 George Lilly. 4 ;Licensed under the terms of the GNU General Public License. 5 ;See attached copy of the License. 6 ; 7 ;This program is free software; you can redistribute it and/or modify 8 ;it under the terms of the GNU General Public License as published by 9 ;the Free Software Foundation; either version 2 of the License, or 10 ;(at your option) any later version. 11 ; 12 ;This program is distributed in the hope that it will be useful, 13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;GNU General Public License for more details. 16 ; 17 ;You should have received a copy of the GNU General Public License along 18 ;with this program; if not, write to the Free Software Foundation, Inc., 19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 20 ; 21 W "NO ENTRY FROM TOP",! 22 Q 23 ; 24 24 EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS 25 25 ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE -
ccr/trunk/p/C0CPARMS.m
r1331 r1336 1 C0CPARMS 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 SET(INPARMS) 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 CHECK 52 53 54 55 56 57 GET(WHICHP) 58 59 60 61 62 1 C0CPARMS ; CCDCCR/GPL - CCR/CCD PARAMETER PROCESSING ; 1/29/09 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 SET(INPARMS) ;INITIALIZE RUNTIME PARMS USING INPARMS TO OVERRIDE DEFAULTS 21 ; PARAMETERS ARE PASSED AS A STRING: "PARM1:VALUE1^PARM2:VALUE2^ETC" 22 ; THE SAME FORMAT IS USED BY RPC AND COMMAND LINE ENTRY POINTS 23 ; 24 N PTMP ; 25 S C0CPARMS=$NA(^TMP("C0CPARMS",$J)) ;BASE FOR THIS RUN 26 K @C0CPARMS ;START WITH EMPTY PARMS; MAY NOT WANT TO DO THIS KILL 27 I $G(INPARMS)'="" D ; OVERRIDES PROVIDED 28 . N C0CI S C0CI="" 29 . N C0CN S C0CN=1 30 . F S C0CI=$P(INPARMS,"^",C0CN) Q:C0CI="" D ; 31 . . S C0CN=C0CN+1 ;NEXT PARM 32 . . N C1,C2 33 . . S C1=$P(C0CI,":",1) ; PARAMETER 34 . . S C2=$P(C0CI,":",2) ; VALUE 35 . . I C2="" S C2=1 36 . . S @C0CPARMS@(C1)=C2 37 . I C0CN=1 S @C0CPARMS@($P(INPARMS,":",1))=$P(C0CI,":",2) ; ONLY ONE 38 ; THIS IS WHERE WE WILL INSERT CALLS TO THE PARAMETER FILE FOR DEFAULTS 39 ; IF THEY FAIL, THE FOLLOWING WILL BE HARDCODED DEFAULTS 40 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 CHECK ; CHECK TO SEE IF PARMS ARE PRESENT, ELSE RUN SET 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 GET(WHICHP) ;EXTRINSIC TO RETURN THE VALUE OF PARAMETER WHICHP 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
r1331 r1336 1 C0CPROBS 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(IPXML,DFN,OUTXML) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 RPMS 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 VISTA 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 CCD 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 MISSINGVARS 178 179 180 181 182 183 184 185 1 C0CPROBS ; CCDCCR/GPL/CJE - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08 2 ;;1.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 . ; FOR CERTIFICATION - GPL 63 . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 64 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") 65 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") 66 . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 67 . ;S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) ;UNKNOWN NOT MAPPED IN C0CCCR0 68 . ;S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) ;NOT MAPPED IN C0CCCR0 69 . ;S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) ;NOT MAPPED IN C0CCCR0 70 . ;S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) ;NOT MAPPED IN C0CCCR0 71 . ;S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) ;NOT MAPPED IN C0CCCR0 72 . ;S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 73 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$$ZVALUEI^C0CRNF("RECORDING PROVIDER","C0CG1") 74 . ;S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) ;NOT MAPPED IN C0CCCR0 75 . ;S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) ;NOT MAPPED IN C0CCCR0 76 . ;S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") ;NOT MAPPED IN C0CCCR0 77 . ;S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") ;NOT MAPPED IN C0CCCR0 78 . S ARYTMP=$NA(@TARYTMP@(J)) 79 . ; W "ARYTMP= ",ARYTMP,! 80 . K @ARYTMP 81 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 82 . I J=1 D ; FIRST ONE IS JUST A COPY 83 . . ; W "FIRST ONE",! 84 . . D CP^C0CXPATH(ARYTMP,OUTXML) 85 . . ; W "OUTXML ",OUTXML,! 86 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 87 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 88 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 89 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 90 ; ZWR @OUTXML 91 ; $$HTML^DILF( 92 ; GENERATE THE NARITIVE HTML FOR THE CCD 93 I CCD D CCD ; IF THIS IS FOR A CCD 94 D MISSINGVARS 95 Q 96 ; 97 VISTA ; GETS THE PROBLEM LIST FOR VISTA 98 D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC 99 I '$D(RPCRSLT(1)) D Q ; RPC RETURNS NULL 100 . W "NULL RESULT FROM LIST^ORQQPL3 ",! 101 . S @OUTXML@(0)=0 102 . ; Q 103 ; I DEBUG ZWR RPCRSLT 104 S @TVMAP@(0)=RPCRSLT(0) ; SAVE NUMBER OF PROBLEMS 105 F J=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM IN THE LIST 106 . S VMAP=$NA(@TVMAP@(J)) 107 . K @VMAP 108 . I DEBUG W "VMAP= ",VMAP,! 109 . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY 110 . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM 111 . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) 112 . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") 113 . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG 114 . ; turn off acute/chronic for certification gpl 115 . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status 116 . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) 117 . S @VMAP@("PROBLEMCODINGVERSION")="" 118 . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) 119 . ; FOR CERTIFICATION - GPL 120 . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 121 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") 122 . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") 123 . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) 124 . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8) 125 . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9) 126 . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10) 127 . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11) 128 . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12) 129 . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER 130 . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1) 131 . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13) 132 . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14) 133 . S @VMAP@("PROBLEMDTREC")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,15),"DT") 134 . S @VMAP@("PROBLEMINACT")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,16),"DT") 135 . S ARYTMP=$NA(@TARYTMP@(J)) 136 . ; W "ARYTMP= ",ARYTMP,! 137 . K @ARYTMP 138 . D MAP^C0CXPATH(IPXML,VMAP,ARYTMP) ; 139 . I J=1 D ; FIRST ONE IS JUST A COPY 140 . . ; W "FIRST ONE",! 141 . . D CP^C0CXPATH(ARYTMP,OUTXML) 142 . . ; W "OUTXML ",OUTXML,! 143 . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 144 . . D INSINNER^C0CXPATH(OUTXML,ARYTMP) 145 ; ZWR ^TMP("C0CCCR",$J,"PROBVALS",*) 146 ; ZWR ^TMP("C0CCCR",$J,"PROBARYTMP",*) ; SHOW THE RESULTS 147 ; ZWR @OUTXML 148 ; $$HTML^DILF( 149 ; GENERATE THE NARITIVE HTML FOR THE CCD 150 I CCD D CCD ; IF THIS IS FOR A CCD 151 D MISSINGVARS 152 Q 153 CCD 154 N HTMP,HOUT,HTMLO,C0CPROBI,ZX 155 F C0CPROBI=1:1:RPCRSLT(0) D ; FOR EACH PROBLEM 156 . S VMAP=$NA(@TVMAP@(C0CPROBI)) 157 . I DEBUG W "VMAP =",VMAP,! 158 . D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Body/PROBLEMS-HTML","HTMP") ; GET THE HTML FROM THE TEMPLATE 159 . D UNMARK^C0CXPATH("HTMP") ; REMOVE <PROBLEMS-HTML> MARKUP 160 . ; D PARY^C0CXPATH("HTMP") ; PRINT IT 161 . D MAP^C0CXPATH("HTMP",VMAP,"HOUT") ; MAP THE VARIABLES 162 . ; D PARY^C0CXPATH("HOUT") ; PRINT IT AGAIN 163 . I C0CPROBI=1 D ; FIRST ONE IS JUST A COPY 164 . . D CP^C0CXPATH("HOUT","HTMLO") 165 . I C0CPROBI>1 D ; AFTER THE FIRST, INSERT INNER HTML 166 . . I DEBUG W "DOING INNER",! 167 . . N HTMLBLD,HTMLTMP 168 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",1,HTMLO(0)-1) 169 . . D QUEUE^C0CXPATH("HTMLBLD","HOUT",2,HOUT(0)-1) 170 . . D QUEUE^C0CXPATH("HTMLBLD","HTMLO",HTMLO(0),HTMLO(0)) 171 . . D BUILD^C0CXPATH("HTMLBLD","HTMLTMP") 172 . . D CP^C0CXPATH("HTMLTMP","HTMLO") 173 . . ; D INSINNER^C0CXPATH("HOUT","HTMLO","//") 174 I DEBUG D PARY^C0CXPATH("HTMLO") 175 D INSB4^C0CXPATH(OUTXML,"HTMLO") ; INSERT AT TOP OF SECTION 176 Q 177 MISSINGVARS 178 N PROBSTMP,I 179 D MISSING^C0CXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS 180 I PROBSTMP(0)>0 D ; IF THERE ARE MISSING VARS - 181 . ; STRINGS MARKED AS @@X@@ 182 . W !,"PROBLEMS Missing list: ",! 183 . F I=1:1:PROBSTMP(0) W PROBSTMP(I),! 184 Q 185 ; -
ccr/trunk/p/C0CPROC.m
r1331 r1336 1 C0CPROC 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 SETVARS 25 26 27 28 29 30 31 32 EXTRACT(PROCXML,DFN,PROCOUT) 33 34 35 36 37 38 39 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 PRV(IARY) 101 102 103 104 105 106 107 108 DATE(ISTR) 109 110 111 CPT(ISTR) 112 113 114 115 116 117 118 119 120 121 122 123 124 125 MAP(PROCXML,C0CPRC,PROCOUT) 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 1 C0CPROC ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROCEDURES ; 01/21/10 2 ;;1.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 ; ADDITION FOR CERTIFICATION 29 S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) 30 Q 31 ; 32 EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE 33 ; PROCXML AND PROCOUT ARE PASSED BY NAME SO GLOBALS CAN BE USED 34 ; 35 D SETVARS ; SET UP VARIABLES 36 I '$D(@C0CPRC) D TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; GET VARS IF NOT THERE 37 D MAP(PROCXML,C0CPRC,PROCOUT) ;MAP RESULTS FOR PROCEDURES 38 Q 39 ; 40 TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, 41 ; ENCOUNTERS AND NOTES. RETURNS THEM IN RNF2 ARRAYS PASSED BY NAME 42 ; C0CENC: ENCOUNTERS, C0CPRC: PROCEDURES, C0CNTE: NOTES 43 ; READY TO BE MAPPED TO XML BY MAP^C0CENC, MAP^C0CPROC, AND MAP^C0CCMT 44 ; THESE RETURN ARRAYS ARE NOT INITIALIZED, BUT ARE ADDED TO IF THEY 45 ; EXIST. THIS IS SO THAT ADDITIONAL PROCEDURES CAN BE OBTAINED FROM 46 ; THE SURGERY PACKGE AND ADDITIONAL COMMENTS FROM OTHER CCR SECTIONS 47 ; 48 K VISIT,LST,NOTE,C0CLPRC 49 ; C0CLPRC IS A LOOKUP TABLE FOR USE IN BUILDING ENCOUNTERS 50 ; FORMAT C0CLPRC(VISITIEN,CPT)=PROCOBJECTID FOR BUILDING LINKS TO PROCEDURES 51 D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE 52 ; NEED TO ADD START AND END DATES FROM PARAMETERS 53 N ZI S ZI="" 54 N PREVCPT,PREVDT S (PREVCPT,PREVDT)="" 55 F S ZI=$O(VISIT(ZI),-1) Q:ZI="" D ; REVERSE TIME ORDER - MOST RECENT FIRST 56 . N ZDATE 57 . S ZDATE=$$DATE(VISIT(ZI,"DATE",0)) 58 . S ZPRVARY=$NA(VISIT(ZI,"PRV")) 59 . N ZPRV 60 . S ZPRV=$$PRV(ZPRVARY) ; THE PRIMARY PROVIDER OBJECT IN THE FORM 61 . ; ACTORPROVIDER_IEN WHERE IEN IS THE PROVIDER IEN IN NEW PERSON 62 . N ZJ S ZJ="" 63 . F S ZJ=$O(VISIT(ZI,"CPT",ZJ)) Q:ZJ="" D ;FOR EACH CPT SEG 64 . . N ZRNF 65 . . N ZCPT S ZCPT=$$CPT(VISIT(ZI,"CPT",ZJ)) ;GET CPT CODE AND TEXT 66 . . I ZCPT'="" D ;IF CPT CODE IS PRESENT 67 . . . I (ZCPT=PREVCPT)&(ZDATE=PREVDT) Q ; NO DUPS ALLOWED 68 . . . W !,ZCPT," ",ZDATE," ",ZPRV 69 . . . S ZRNF("PROCACTOROBJID")=ZPRV 70 . . . N PROCCODE S PROCCODE=$P(ZCPT,U,1) 71 . . . S ZRNF("PROCCODE")=PROCCODE 72 . . . S ZRNF("PROCCODESYS")="CPT-4" 73 . . . S ZRNF("PROCDATETEXT")="Procedure Date" 74 . . . S ZRNF("PROCDATETIME")=ZDATE 75 . . . S ZRNF("PROCDESCOBJATTRCODE")="" ;NO PROC ATTRIBUTES YET 76 . . . S ZRNF("PROCDESCOBJATTR")="" 77 . . . S ZRNF("PROCDESCOBJATTRCODESYS")="" ;WE DON'T HAVE PROC ATTRIBUTES 78 . . . S ZRNF("PROCDESCOBJATTRVAL")="" 79 . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) 80 . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET 81 . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET 82 . . . ; additions for Certification - need to have EKG in Results 83 . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT 84 . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ 85 . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS 86 . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? 87 . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE 88 . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY 89 . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl 90 . . . W !,"CPT=",ZCPT 91 . . . I ZCPT["93000" D ; THIS IS AN EKG 92 . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS 93 . . . . M ^GPL("RNF2")=@C0CPRSLT 94 . . . S PREVCPT=ZCPT 95 . . . S PREVDT=ZDATE 96 N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) 97 M @ZRIM=@C0CPRC@("V") 98 Q 99 ; 100 PRV(IARY) ; RETURNS THE PRIMARY PROVIDER FROM THE "PRV" ARRAY PASSED BY NAME 101 N ZI,ZR,ZRTN S ZI="" S ZR="" S ZRTN="" 102 F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ; FOR EACH PRV SEG 103 . I ZR'="" Q ;ONLY WANT THE FIRST PRIMARY PROVIDER 104 . I $P(@IARY@(ZI),U,5)=1 S ZR=$P(@IARY@(ZI),U,1) 105 I ZR'="" S ZRTN="ACTORPROVIDER_"_ZR 106 Q ZRTN 107 ; 108 DATE(ISTR) ; EXTRINSIC TO RETURN THE DATE IN CCR FORMAT 109 Q $$FMDTOUTC^C0CUTIL(ISTR,"DT") 110 ; 111 CPT(ISTR) ; EXTRINSIC THAT SEARCHES FOR CPT CODES AND RETURNS 112 ; CPT^CATEGORY^TEXT 113 N Z1,Z2,Z3,ZRTN 114 S Z1=$P(ISTR,U,1) 115 I Z1="" D ; 116 . I ISTR["(CPT-4 " S Z1=$P($P(ISTR,"(CPT-4 ",2),")",1) 117 I Z1'="" D ; IF THERE IS A CPT CODE IN THERE 118 . ;S Z1=$P(ISTR,U,1) 119 . S Z2=$P(ISTR,U,2) 120 . S Z3=$P(ISTR,U,3) 121 . S ZRTN=Z1_U_Z2_U_Z3 122 E S ZRTN="" 123 Q ZRTN 124 ; 125 MAP(PROCXML,C0CPRC,PROCOUT) ; MAP PROCEDURES XML 126 ; 127 N ZTEMP S ZTEMP=$NA(^TMP("C0CCCR",$J,DFN,"PROCTEMP")) ;WORK AREA FOR TEMPLATE 128 K @ZTEMP 129 N ZBLD 130 S ZBLD=$NA(^TMP("C0CCCR",$J,DFN,"PROCBLD")) ; BUILD LIST AREA 131 D QUEUE^C0CXPATH(ZBLD,PROCXML,1,1) ; FIRST LINE 132 N ZINNER 133 D QUERY^C0CXPATH(PROCXML,"//Procedures/Procedure","ZINNER") ;ONE PROC 134 N ZTMP,ZVAR,ZI 135 S ZI="" 136 F S ZI=$O(@C0CPRC@("V",ZI)) Q:ZI="" D ;FOR EACH PROCEDURE 137 . S ZTMP=$NA(@ZTEMP@(ZI)) ;THIS PROCEDURE XML 138 . S ZVAR=$NA(@C0CPRC@("V",ZI)) ;THIS PROCEDURE VARIABLES 139 . D MAP^C0CXPATH("ZINNER",ZVAR,ZTMP) ; MAP THE PROCEDURE 140 . D QUEUE^C0CXPATH(ZBLD,ZTMP,1,@ZTMP@(0)) ;QUE FOR BUILD 141 D QUEUE^C0CXPATH(ZBLD,PROCXML,@PROCXML@(0),@PROCXML@(0)) 142 N ZZTMP 143 D BUILD^C0CXPATH(ZBLD,PROCOUT) ;BUILD FINAL XML 144 K @ZTEMP,@ZBLD,@C0CPRC 145 Q 146 ; -
ccr/trunk/p/C0CRIMA.m
r1331 r1336 1 C0CRIMA 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 ANALYZE(BEGDFN,DFNCNT,APARMS) 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 SETATTR(SDFN) 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 RESET 155 156 157 158 159 CLIST 160 161 162 163 164 165 166 167 168 169 170 171 172 173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 CHKSUM(CKDFN) 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 CCOUNT 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 CNTLST(INLST) 257 258 259 260 261 262 263 264 265 266 267 268 XCPAT(CPATCAT,CPATPARM) 269 270 271 272 273 274 275 276 277 278 279 280 CPAT(CPATCAT) 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 PATC(DFN) 297 298 299 300 301 302 303 304 305 306 307 308 309 APUSH(AMAP,AVAL) 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 ASETUP 325 326 327 328 329 330 331 AINIT 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 APOST(PRSLT,PTBL,PVAL) 366 367 368 369 370 371 372 373 374 375 376 GETPA(RTN,DFN,ISEC,IVAR) 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 PATD(DFN,ISEC,IVAR) 400 401 402 403 404 405 406 407 CAGET(RTN,IATTR) 408 409 410 411 412 413 PCLST(LSTRTN,IATTR) 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 DCPAT(CATTR) 439 440 441 442 443 444 445 446 447 448 449 450 451 452 RPCGV(RTN,DFN,WHICH) 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 ZGVWRK(ZWHICH) 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 DPATV(DFN,IWHICH) 490 491 492 493 494 495 496 497 498 499 500 RIM2RNF(R2RTN,DFN,RWHICH) 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 RIM2CSV(DFN) 527 528 529 530 531 532 533 1 C0CRIMA ; CCDCCR/GPL - RIM REPORT ROUTINES; 6/6/08 2 ;;1.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 ANALYZE(BEGDFN,DFNCNT,APARMS) ; RIM COHERANCE ANALYSIS ROUTINE 40 ; BEGINS AT BEGDFN AND GOES FOR DFNCNT PATIENTS 41 ; TO RESUME AT NEXT PATIENT, USE BEGDFN="" 42 ; USE RESET^C0CRIMA TO RESET TO TOP OF PATIENT LIST 43 ; APARMS ARE PARAMETERS TO BE USED IN THE EXTRACTION 44 ; SEE C0CPARMS FOR SUPPORTED PARAMTERS 45 ; 46 N RIMARY,RIMTMP,RIMI,RIMDFN,RATTR 47 N CCRGLO 48 S C0CCHK=0 ; CHECKSUM FLAG 49 D ASETUP ; SET UP VARIABLES AND GLOBALS 50 D AINIT ; INITIALIZE ATTRIBUTE VALUE TABLE 51 I '$D(@RIMBASE@("RESUME")) S @RIMBASE@("RESUME")=$O(^DPT(0)) ; FIRST TIME 52 S RESUME=@RIMBASE@("RESUME") ; WHERE WE LEFT OFF LAST RUN 53 S RIMDFN=BEGDFN ; BEGIN WITH THE BEGDFN PATIENT 54 I RIMDFN="" S RIMDFN=RESUME 55 I +RIMDFN=0 D Q ; AT THE END OF THE PATIENTS 56 . W "END OF PATIENT LIST, CALL RESET^C0CRIMA",! 57 I '$D(APARMS) S APARMS="" ; DEFAULT NO OVERRIDE PARMS 58 F RIMI=1:1:DFNCNT D Q:+RIMDFN=0 ; FOR DFNCNT NUMBER OF PATIENTS OR END 59 . K @RIMBASE@("VARS",RIMDFN) ; CLEAR OUT OLD VARS 60 . D CCRRPC^C0CCCR(.CCRGLO,RIMDFN,APARMS,"CCR") ;PROCESS THE CCR 61 . W RIMDFN,! 62 . ; 63 . ; COPY ALL THE VARIABLES TO THE RIM MAP AREA INDEXED BY PATIENT 64 . ; 65 . I $D(^TMP("C0CCCR",$J,"PROBVALS",1)) D ; PROBLEM VARS EXISTS 66 . . M @RIMBASE@("VARS",RIMDFN,"PROBLEMS")=^TMP("C0CCCR",$J,"PROBVALS") 67 . . S @RIMBASE@("VARS",RIMDFN,"PROBLEMS",0)=$O(^TMP("C0CCCR",$J,"PROBVALS",""),-1) 68 . I $D(^TMP("C0CCCR",$J,"VITALS",1)) D ; VITALS VARS EXISTS 69 . . M @RIMBASE@("VARS",RIMDFN,"VITALS")=^TMP("C0CCCR",$J,"VITALS") 70 . I $D(^TMP("C0CCCR",$J,"MEDMAP",1)) D ; MEDS VARS EXISTS 71 . . M @RIMBASE@("VARS",RIMDFN,"MEDS")=^TMP("C0CCCR",$J,"MEDMAP") 72 . I $D(^TMP("C0CCCR",$J,"ALERTS",1,"ALERTOBJECTID")) D ; ALERTS EXIST 73 . . W "FOUND ALERT VARS",! 74 . . M @RIMBASE@("VARS",RIMDFN,"ALERTS")=^TMP("C0CCCR",$J,"ALERTS") 75 . I $D(^TMP("C0CCCR",$J,"RESULTS",0)) D ; RESULTS EXIST 76 . . W "FOUND RESULTS VARS",! 77 . . M @RIMBASE@("VARS",RIMDFN,"RESULTS")=^TMP("C0CCCR",$J,"RESULTS") 78 . S C0CCHK=0 79 . I $$CHKSUM(RIMDFN) D ; CHECKSUM HAS CHANGED 80 . . W "CHECKSUM IS NEW OR HAS CHANGED",! 81 . . ;ZWR ^TMP("C0CRIM","CHKSUM",RIMDFN,*) 82 . . S C0CCHK=1 83 . K ^TMP("C0CCCR",$J) ; KILL WORK AREA FOR CCR BUILDING 84 . ; 85 . ; EVALUATE THE VARIABLES AND CREATE AN ATTRIBUTE MAP 86 . ; 87 . S RATTR=$$SETATTR(RIMDFN) ; SET THE ATTRIBUTE STRING BASED ON THE VARS 88 . S @RIMBASE@("ATTR",RIMDFN)=RATTR ; SAVE THE ATRIBUTES FOR THIS PAT 89 . ; 90 . ; INCREMENT THE COUNT OF PATIENTS WITH THESE ATTRIBUTES IN ATTRTBL 91 . ; 92 . ; I '$D(@RIMBASE@("ATTRTBL",RATTR)) D ; IF FIRST PAT WITH THESE ATTRS 93 . ; . S @RIMBASE@("ATTRTBL",RATTR)=0 ; DEFAULT VALUE TO BE INCREMENTED 94 . ; S @RIMBASE@("ATTRTBL",RATTR)=@RIMBASE@("ATTRTBL",RATTR)+1 ; INCREMENT 95 . ; 96 . N CATNAME,CATTBL 97 . ; S CATBASE=$NA(@RIMBASE@("ANALYSIS")) 98 . S CATNAME="" 99 . D CPUSH(.CATNAME,RIMBASE,"RIMTBL",RIMDFN,RATTR) ; ADD TO CATEGORY 100 . W "CATEGORY NAME: ",CATNAME,! 101 . ; 102 . F S RIMDFN=$O(^DPT(RIMDFN)) Q:'$$PTST^C0CSYS(RIMDFN) ; NEXT PATIENT 103 . ; PTST TESTS TO SEE IF PATIENT WAS MERGED 104 . ; IF CCRTEST=0, PTST WILL CHECK TO SEE IF THIS IS A TEST PATIENT 105 . ; AND WE SKIP IT 106 . S @RIMBASE@("RESUME")=RIMDFN ; WHERE WE ARE LEAVING OFF THIS RUN 107 ; D PARY^C0CXPATH(@RIMBASE@("ATTRTBL")) 108 Q 109 ; 110 SETATTR(SDFN) ; SET ATTRIBUTES BASED ON VARS 111 N SBASE,SATTR 112 S SBASE=$NA(@RIMBASE@("VARS",SDFN)) 113 D APOST("SATTR","RIMTBL","HEADER") 114 I $D(@SBASE@("PROBLEMS",1)) D ; 115 . D APOST("SATTR","RIMTBL","PROBLEMS") 116 . ; W "POSTING PROBLEMS",! 117 I $D(@SBASE@("VITALS",1)) D APOST("SATTR","RIMTBL","VITALS") 118 I $D(@SBASE@("IMMUNE",1)) D ;IMMUNIZATIONS PRESENT 119 . D APOST("SATTR","RIMTBL","IMMUNE") 120 . N ZR,ZI 121 . D GETPA(.ZR,SDFN,"IMMUNE","IMMUNEPRODUCTCODE") 122 . I ZR(0)>0 D APOST("SATTR","RIMTBL","IMMUNECODE") ;IMMUNIZATION CODES 123 I $D(@SBASE@("MEDS",1)) D ; IF THE PATIENT HAS MEDS VARIABLES 124 . D APOST("SATTR","RIMTBL","MEDS") 125 . N ZR,ZI 126 . D GETPA(.ZR,SDFN,"MEDS","MEDPRODUCTNAMECODEVALUE") ;CHECK FOR MED CODES 127 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 128 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 129 . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","MEDSCODE") ;CODES 130 . ; D PATD^C0CRIMA(2,"MEDS","MEDPRODUCTNAMECODEVALUE") CHECK FOR MED CODES 131 I $D(@SBASE@("ALERTS",1)) D ; IF THE PATIENT HAS ALERTS 132 . D APOST("SATTR","RIMTBL","ALERTS") 133 . N ZR,ZI 134 . D GETPA(.ZR,SDFN,"ALERTS","ALERTAGENTPRODUCTCODEVALUE") ;REACTANT CODES 135 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 136 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 137 . . . I $P(ZR(ZI),"^",2)'="" D APOST("SATTR","RIMTBL","ALERTSCODE") ;CODES 138 I $D(@SBASE@("RESULTS",1)) D ; IF THE PATIENT HAS LABS VARIABLES 139 . D APOST("SATTR","RIMTBL","RESULTS") 140 . N ZR,ZI 141 . S ZR(0)=0 ; INITIALIZE TO NONE 142 . D RPCGV(.ZR,SDFN,"RESULTS") ;CHECK FOR LABS CODES 143 . ; D PARY^C0CXPATH("ZR") ; 144 . I ZR(0)>0 D ; VAR LOOKUP WAS GOOD, CHECK FOR NON=NULL RETURN 145 . . F ZI=1:1:ZR(0) D ; LOOP THROUGH RETURNED VAR^VALUE PAIRS 146 . . . I $P(ZR(ZI),"^",2)="RESULTTESTCODINGSYSTEM" D ; LOINC CODE CHECK 147 . . . . I $P(ZR(ZI),"^",3)="LOINC" D APOST("SATTR","RIMTBL","RESULTSLN") ; 148 ; D APOST("SATTR","RIMTBL","NOTEXTRACTED") ; OUTPUT NOT YET PRODUCED 149 I $D(@SBASE@("PROCEDURES",1)) D ; 150 . D APOST("SATTR","RIMTBL","PROCEDURES") 151 W "ATTRIBUTES: ",SATTR,! 152 Q SATTR 153 ; 154 RESET ; KILL RESUME INDICATOR TO START OVER. ALSO KILL RIM TMP VALUES 155 K ^TMP("C0CRIM","RESUME") 156 K ^TMP("C0CRIM") 157 Q 158 ; 159 CLIST ; LIST THE CATEGORIES 160 ; 161 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 162 N CLBASE,CLNUM,ZI,CLIDX 163 S CLBASE=$NA(@RIMBASE@("RIMTBL","CATS")) 164 S CLNUM=@CLBASE@(0) 165 F ZI=1:1:CLNUM D ; LOOP THROUGH THE CATEGORIES 166 . S CLIDX=@CLBASE@(ZI) 167 . W "(",$P(@CLBASE@(CLIDX),"^",1) 168 . W ":",$P(@CLBASE@(CLIDX),"^",2),") " 169 . W CLIDX,! 170 ; D PARY^C0CXPATH(CLBASE) 171 Q 172 ; 173 CPUSH(CATRTN,CBASE,CTBL,CDFN,CATTR) ; ADD PATIENTS TO CATEGORIES 174 ; AND PASS BACK THE NAME OF THE CATEGORY TO WHICH THE PATIENT 175 ; WAS ADDED IN CATRTN, WHICH IS PASSED BY REFERENCE 176 ; CBASE IS WHERE TO PUT THE CATEGORIES PASSED BY NAME 177 ; CTBL IS THE NAME OF THE TABLE USED TO CREATE THE ATTRIBUTES, 178 ; PASSED BY NAME AND USED TO CREATE CATEGORY NAMES IE "@CTBL_X" 179 ; WHERE X IS THE CATEGORY NUMBER. CTBL(0) IS THE NUMBER OF CATEGORIES 180 ; CATBL(X)=CATTR STORES THE ATTRIBUTE IN THE CATEGORY 181 ; CDFN IS THE PATIENT DFN, CATTR IS THE ATTRIBUTE STRING 182 ; THE LIST OF PATIENTS IN A CATEGORY IS STORED INDEXED BY CATEGORY 183 ; NUMBER IE CTBL_X(CDFN)="" 184 ; 185 ; N CCTBL,CENTRY,CNUM,CCOUNT,CPATLIST 186 S CCTBL=$NA(@CBASE@(CTBL,"CATS")) 187 W "CBASE: ",CCTBL,! 188 ; 189 I '$D(@CCTBL@(CATTR)) D ; FIRST PATIENT IN THIS CATEGORY 190 . D PUSH^C0CXPATH(CCTBL,CATTR) ; ADD THE CATEGORY TO THE ARRAY 191 . S CNUM=@CCTBL@(0) ; ARRAY ENTRY NUMBER FOR THIS CATEGORY 192 . S CENTRY=CTBL_"_"_CNUM_U_0 ; TABLE ENTRY DEFAULT 193 . S @CCTBL@(CATTR)=CENTRY ; DEFAULT NON INCREMENTED TABLE ENTRY 194 . ; NOTE THAT P1 IS THE CATEGORY NAME MADE UP OF THE TABLE NAME 195 . ; AND CATGORY ARRAY NUMBER. P2 IS THE COUNT WHICH IS INITIALLY 0 196 ; 197 S CCOUNT=$P(@CCTBL@(CATTR),U,2) ; COUNT OF PATIENTS IN THIS CATEGORY 198 S CCOUNT=CCOUNT+1 ; INCREMENT THE COUNT 199 S $P(@CCTBL@(CATTR),U,2)=CCOUNT ; PUT IT BACK 200 ; 201 S CATRTN=$P(@CCTBL@(CATTR),U,1) ; THE CATEGORY NAME WHICH IS RETURNED 202 ; 203 S CPATLIST=$NA(@CBASE@(CTBL,"PATS",CATRTN)) ; BASE OF PAT LIST FOR THIS CAT 204 W "PATS BASE: ",CPATLIST,! 205 S @CPATLIST@(CDFN)="" ; ADD THIS PATIENT TO THE CAT PAT LIST 206 ; 207 Q 208 ; 209 CHKSUM(CKDFN) ; DOES A CHECKSUM AND STORES IT IN MUMPS GLOBALS 210 ; 211 S C0CCKB=$NA(^TMP("C0CRIM","CHKSUM")) ;CHECKSUM BASE 212 S C0CGLB=$NA(^TMP("C0CRIM","VARS")) ;CCR VARIABLE BASE 213 S C0CI="" 214 F S C0CI=$O(@C0CGLB@(CKDFN,C0CI)) Q:C0CI="" D ;FOR EACH DOMAIN 215 . ;W "DFN:",CKDFN," DOMAIN:",C0CI,! 216 . S C0CJ=$NA(@C0CGLB@(CKDFN,C0CI)) 217 . I C0CI="HEADER" D ; HAVE TO TAKE OUT THE "DATE GENERATED" 218 . . S C0CDT=@C0CGLB@(CKDFN,C0CI,1,"DATETIME") 219 . . K @C0CGLB@(CKDFN,C0CI,1,"DATETIME") 220 . S C0CCK(C0CI)=$$CHKSUM^XUSESIG1(C0CJ) 221 . I C0CI="HEADER" D ; PUT IT BACK 222 . . S @C0CGLB@(CKDFN,C0CI,1,"DATETIME")=C0CDT 223 S C0CK="C0CCK" ; 224 S C0CALL=$$CHKSUM^XUSESIG1(C0CK) ;CHECKSUM OF ALL DOMAIN CHECKSUMS 225 S CHKR=0 ; RESULT DEFAULT 226 I $D(^TMP("C0CRIM","CHKSUM",CKDFN,"ALL")) D ; OLD CHECKSUM EXISTS 227 . I @C0CCKB@(CKDFN,"ALL")'=C0CALL S CHKR=1 228 E S CHKR=1 ;CHECKSUM IS NEW 229 S @C0CCKB@(CKDFN,"ALL")=C0CALL 230 M @C0CCKB@(CKDFN,"DOMAIN")=C0CCK 231 ;ZWR ^TMP("C0CRIM","CHKSUM",CKDFN,*) 232 Q CHKR 233 ; 234 CCOUNT ; RECOUNT THE CATEGORIES.. USE IN CASE OF RESTART OF ANALYZE 235 ; 236 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 237 N ZI,ZJ,ZCNT,ZIDX,ZCAT,ZATR,ZTOT 238 S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES 239 S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS 240 S ZTOT=0 ; INITIALIZE OVERALL TOTAL 241 F ZI=1:1:@ZCBASE@(0) D ; FOR ALL CATS 242 . S ZCNT=0 243 . S ZATR=@ZCBASE@(ZI) ; THE ATTRIBUTE OF THE CATEGORY 244 . S ZCAT=$P(@ZCBASE@(ZATR),"^",1) ; USE IT TO LOOK UP THE CATEGORY NAME 245 . ; S ZIDX=$O(@ZPBASE@(ZCAT,"")) ; FIRST PATIENT IN LIST 246 . ; F ZJ=0:0 D Q:$O(@ZPBASE@(ZCAT,ZIDX))="" ; ALL PATIENTS IN THE LISTS 247 . ; . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT 248 . ; . W ZCAT," DFN:",ZIDX," COUNT:",ZCNT,! 249 . ; . S ZIDX=$O(@ZPBASE@(ZCAT,ZIDX)) 250 . S ZCNT=$$CNTLST($NA(@ZPBASE@(ZCAT))) 251 . S $P(@ZCBASE@(ZATR),"^",2)=ZCNT ; UPDATE THE COUNT IN THE CAT RECORD 252 . S ZTOT=ZTOT+ZCNT 253 W "TOTAL: ",ZTOT,! 254 Q 255 ; 256 CNTLST(INLST) ; RETURNS THE NUMBER OF ELEMENTS IN THE LIST 257 ; INLST IS PASSED BY NAME 258 N ZI,ZDX,ZCOUNT 259 W INLST,! 260 S ZCOUNT=0 261 S ZDX="" 262 F ZI=$O(@INLST@(ZDX)):0 D Q:$O(@INLST@(ZDX))="" ; LOOP UNTIL THE END 263 . S ZCOUNT=ZCOUNT+1 264 . S ZDX=$O(@INLST@(ZDX)) 265 . W "ZDX:",ZDX," ZCNT:",ZCOUNT,! 266 Q ZCOUNT 267 ; 268 XCPAT(CPATCAT,CPATPARM) ; EXPORT TO FILE ALL PATIENTS IN CATEGORY CPATCAT 269 ; 270 I '$D(CPATPARM) S CPATPARM="" 271 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 272 N ZI,ZJ,ZC,ZPATBASE 273 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) 274 S ZI="" 275 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 276 . S ZI=$O(@ZPATBASE@(ZI)) 277 . D XPAT^C0CCCR(ZI,CPATPARM) ; EXPORT THE PATIENT TO A FILE 278 Q 279 ; 280 CPAT(CPATCAT) ; SHOW PATIENT DFNS FOR A CATEGORY CPATCAT 281 ; 282 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 283 N ZI,ZJ,ZC,ZPATBASE 284 S ZC=0 ; COUNT FOR SPACING THE PRINTOUT 285 S ZPATBASE=$NA(@RIMBASE@("RIMTBL","PATS",CPATCAT)) 286 S ZI="" 287 F ZJ=0:0 D Q:$O(@ZPATBASE@(ZI))="" ; TIL END 288 . S ZI=$O(@ZPATBASE@(ZI)) 289 . S ZC=ZC+1 ; INCREMENT OUTPUT PER LINE COUNT 290 . W ZI," " 291 . I ZC=10 D ; NEW LINE 292 . . S ZC=0 293 . . W ! 294 Q 295 ; 296 PATC(DFN) ; DISPLAY THE CATEGORY FOR THIS PATIENT 297 ; 298 N ATTR S ATTR="" 299 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 300 . D ANALYZE(DFN,1) ; EXTRACT THE RIM VARIABLE FOR THIS PATIENT 301 S ATTR=^TMP("C0CRIM","ATTR",DFN) 302 I ATTR="" W "THIS PATIENT NOT ANALYZED.",! Q ;NO ATTRIBUTES FOUND 303 I $D(^TMP("C0CRIM","RIMTBL","CATS",ATTR)) D ; FOUND A CAT 304 . N CAT 305 . S CAT=$P(^TMP("C0CRIM","RIMTBL","CATS",ATTR),U,1) ; LOOK UP THE CAT 306 . W CAT,": ",ATTR,! 307 Q 308 ; 309 APUSH(AMAP,AVAL) ; ADD AVAL TO ATTRIBUTE MAP AMAP (AMAP PASSED BY NAME) 310 ; AMAP IS FORMED FOR ARRAY ACCESS: AMAP(0) IS THE COUNT 311 ; AND AMAP(N)=AVAL IS THE NTH AVAL 312 ; ALSO HASH ACCESS AMAP(AVAL)=N WHERE N IS THE ASSIGNED ORDER OF THE 313 ; MAP VALUE. INSTANCES OF THE MAP WILL USE $P(X,U,N)=AVAL TO PLACE 314 ; THE ATTRIBUTE IN ITS RIGHT PLACE. THE ATTRIBUTE VALUE IS STORED 315 ; SO THAT DIFFERENT MAPS CAN BE AUTOMATICALLY CROSSWALKED 316 ; 317 I '$D(@AMAP) D ; IF THE MAP DOES NOT EXIST 318 . S @AMAP@(0)=0 ; HAS ZERO ELEMENTS 319 S @AMAP@(0)=@AMAP@(0)+1 ;INCREMENT ELEMENT COUNT 320 S @AMAP@(@AMAP@(0))=AVAL ; ADD THE VALUE TO THE ARRAY 321 S @AMAP@(AVAL)=@AMAP@(0) ; ADD THE VALUE TO THE HASH WITH ARRAY REF 322 Q 323 ; 324 ASETUP ; SET UP GLOBALS AND VARS RIMBASE AND RIMTBL 325 I '$D(RIMBASE) S RIMBASE=$NA(^TMP("C0CRIM")) 326 I '$D(@RIMBASE) S @RIMBASE="" 327 I '$D(RIMTBL) S RIMTBL=$NA(^TMP("C0CRIM","RIMTBL","TABLE")) ; ATTR TABLE 328 S ^TMP("C0CRIM","TABLES","RIMTBL")=RIMTBL ; TABLE OF TABLES 329 Q 330 ; 331 AINIT ; INITIALIZE ATTRIBUTE TABLE 332 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 333 K @RIMTBL 334 D APUSH(RIMTBL,"EXTRACTED") 335 D APUSH(RIMTBL,"NOTEXTRACTED") 336 D APUSH(RIMTBL,"HEADER") 337 D APUSH(RIMTBL,"NOPCP") 338 D APUSH(RIMTBL,"PCP") 339 D APUSH(RIMTBL,"PROBLEMS") 340 D APUSH(RIMTBL,"PROBCODE") 341 D APUSH(RIMTBL,"PROBNOCODE") 342 D APUSH(RIMTBL,"PROBDATE") 343 D APUSH(RIMTBL,"PROBNODATE") 344 D APUSH(RIMTBL,"VITALS") 345 D APUSH(RIMTBL,"VITALSCODE") 346 D APUSH(RIMTBL,"VITALSNOCODE") 347 D APUSH(RIMTBL,"VITALSDATE") 348 D APUSH(RIMTBL,"VITALSNODATE") 349 D APUSH(RIMTBL,"IMMUNE") 350 D APUSH(RIMTBL,"IMMUNECODE") 351 D APUSH(RIMTBL,"MEDS") 352 D APUSH(RIMTBL,"MEDSCODE") 353 D APUSH(RIMTBL,"MEDSNOCODE") 354 D APUSH(RIMTBL,"MEDSDATE") 355 D APUSH(RIMTBL,"MEDSNODATE") 356 D APUSH(RIMTBL,"ALERTS") 357 D APUSH(RIMTBL,"ALERTSCODE") 358 D APUSH(RIMTBL,"RESULTS") 359 D APUSH(RIMTBL,"RESULTSLN") 360 D APUSH(RIMTBL,"PROCEDURES") 361 D APUSH(RIMTBL,"ENCOUNTERS") 362 D APUSH(RIMTBL,"NOTES") 363 Q 364 ; 365 APOST(PRSLT,PTBL,PVAL) ; POST AN ATTRIBUTE PVAL TO PRSLT USING PTBL 366 ; PSRLT AND PTBL ARE PASSED BY NAME. PVAL IS A STRING 367 ; PTBL IS THE NAME OF A TABLE IN @RIMBASE@("TABLES") - "RIMTBL"=ALL VALUES 368 ; PVAL WILL BE PLACED IN THE STRING PRSLT AT $P(X,U,@PTBL@(PVAL)) 369 I '$D(RIMBASE) D ASETUP ; FOR COMMANDLINE PROCESSING 370 N USETBL 371 I '$D(@RIMBASE@("TABLES",PTBL)) D Q ; NO TABLE 372 . W "ERROR NO SUCH TABLE",! 373 S USETBL=@RIMBASE@("TABLES",PTBL) 374 S $P(@PRSLT,U,@USETBL@(PVAL))=PVAL 375 Q 376 GETPA(RTN,DFN,ISEC,IVAR) ; RETURNS ARRAY OF RIM VARIABLES FOR PATIENT DFN 377 ; EXAMPLE: D GETPA(.RT,2,"MEDS","MEDSSTATUSTEXT") 378 ; RETURNS AN ARRAY RT OF VALUES OF MEDSTATUSTEXT FOR PATIENT 2 IN P2 379 ; IN SECTION "MEDS" 380 ; P1 IS THE IEN OF THE MED WITH THE VALUE IE 2^PENDING WOULD BE STATUS 381 ; PENDING FOR MED 2 FOR PATIENT 2 382 ; RT(0) IS THE COUNT OF HOW MANY IN THE ARRAY. NULL VALUES ARE 383 ; RETURNED. RTN IS PASSED BY REFERENCE 384 ; 385 S RTN(0)=0 ; SET NULL DEFAULT RETURN VALUE 386 I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES 387 S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES 388 I '$D(@ZVBASE@(DFN,ISEC,0)) D Q ; NO VARIABLES IN SECTION 389 . W "NO VARIABLES IN THIS SECTION FOR PATIENT ",DFN,! 390 N ZZI,ZZS 391 S ZZS=$NA(@ZVBASE@(DFN,ISEC)) ; SECTION VARIABLE ARRAY FOR THIS PATIENT 392 ; ZWR @ZZS@(1) 393 S RTN(0)=@ZZS@(0) 394 F ZZI=1:1:RTN(0) D ; FOR ALL PARTS OF THIS SECTION ( IE FOR ALL MEDS) 395 . S $P(RTN(ZZI),"^",1)=ZZI ; INDEX FOR VARIABLE 396 . S $P(RTN(ZZI),"^",2)=@ZZS@(ZZI,IVAR) ; THE VALUE OF THE VARIABLE 397 Q 398 ; 399 PATD(DFN,ISEC,IVAR) ; DISPLAY FOR PATIENT DFN THE VARIABLE IVAR 400 ; 401 N ZR 402 D GETPA(.ZR,DFN,ISEC,IVAR) 403 I $D(ZR(0)) D PARY^C0CXPATH("ZR") 404 E W "NOTHING RETURNED",! 405 Q 406 ; 407 CAGET(RTN,IATTR) ; 408 ; GETPA LOOKS AT RIMTBL TO FIND PATIENTS WITH ATTRIBUTE IATTR 409 ; IT DOES NOT SEARCH ALL PATIENTS, ONLY THE ONES WITH THE ATTRIBUTE 410 ; IT RETURNS AN ARRAY OF THE VALUES OF VARIABLE IVAR IN SECTION ISEC 411 Q 412 ; 413 PCLST(LSTRTN,IATTR) ; RETURNS ARRAY OF PATIENTS WITH ATTRIBUTE IATTR 414 ; 415 I '$D(RIMBASE) D AINIT ; INITIALIZE GLOBAL NAMES AND TABLES 416 N ZLST 417 S @LSTRTN@(0)=0 ; DEFAULT RETURN NONE 418 S ZCBASE=$NA(@RIMBASE@("RIMTBL","CATS")) ; BASE OF CATEGORIES 419 S ZPBASE=$NA(@RIMBASE@("RIMTBL","PATS")) ; BASE OF PATIENTS 420 N ZNC ; ZNC IS NUMBER OF CATEGORIES 421 S ZNC=@ZCBASE@(0) 422 I ZNC=0 Q ; NO CATEGORIES TO SEARCH 423 N ZAP ; ZAP IS THE PIECE INDEX OF THE ATTRIBUTE IN THE RIM ATTR TABLE 424 S ZAP=@RIMBASE@("RIMTBL","TABLE",IATTR) 425 N ZI,ZCATTBL,ZATBL,ZCNT,ZPAT 426 F ZI=1:1:ZNC D ; FOR ALL CATEGORIES 427 . S ZATBL=@ZCBASE@(ZI) ; PULL OUT ATTR TBL FOR CAT 428 . I $P(ZATBL,"^",ZAP)'="" D ; CAT HAS ATTR 429 . . S ZCATTBL=$P(@ZCBASE@(ZATBL),"^",1) ; NAME OF TBL 430 . . M @LSTRTN=@ZPBASE@(ZCATTBL) ; MERGE PATS FROM CAT 431 S ZCNT=0 ; INITIALIZE COUNT OF PATIENTS 432 S ZPAT=0 ; START AT FIRST PATIENT IN LIST 433 F S ZPAT=$O(@LSTRTN@(ZPAT)) Q:ZPAT="" D ; 434 . S ZCNT=ZCNT+1 435 S @LSTRTN@(0)=ZCNT ; COUNT OF PATIENTS IN ARRAY 436 Q 437 ; 438 DCPAT(CATTR) ; DISPLAY LIST OF PATIENTS WITH ATTRIBUTE CATTR 439 ; 440 ;N ZR 441 D PCLST("ZR",CATTR) 442 I ZR(0)=0 D Q ; 443 . W "NO PATIENTS RETURNED",! 444 E D ; 445 . N ZI S ZI=0 446 . F S ZI=$O(ZR(ZI)) Q:ZI="" D ; 447 . . W !,ZI 448 . ;D PARY^C0CXPATH("ZR") ; PRINT ARRAY 449 . W !,"COUNT=",ZR(0) 450 Q 451 ; 452 RPCGV(RTN,DFN,WHICH) ; RPC GET VARS 453 ; RETURNS IN RTN (PASSED BY REFERENCE) THE VARS AND VALUES 454 ; FOUND AT INARY RTN(X)="VAR^VALUE" RTN(0) IS THE COUNT 455 ; DFN IS THE PATIENT NUMBER. 456 ; WHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","IMMUNE" 457 ; OR OTHER SECTIONS AS THEY ARE ADDED 458 ; THIS IS MEANT TO BE AVAILABLE AS AN RPC 459 I '$D(RIMBASE) D ASETUP ; FOR COMMAND LINE CALLS 460 S ZVBASE=$NA(@RIMBASE@("VARS")) ; BASE OF VARIABLES 461 S RTN(0)=0 ; DEFAULT NOTHING IS RETURNED 462 N ZZGI 463 I WHICH="ALL" D ; VARIABLES FROM ALL SECTIONS 464 . F ZZGI="HEADER","PROBLEMS","VITALS","MEDS","ALERTS","RESULTS","IMMUNE","PROCEDURES" D ; 465 . . D ZGVWRK(ZZGI) ; DO EACH SECTION 466 . . I $G(DEBUG)'="" W "DID ",ZZGI,! 467 E D ZGVWRK(WHICH) ; ONLY ONE SECTION ASKED FOR 468 Q 469 ; 470 ZGVWRK(ZWHICH) ; DO ONE SECTION FOR RPCGV 471 ; 472 N ZZGN ; NAME FOR SECTION VARIABLES 473 S ZZGN=$NA(@ZVBASE@(DFN,ZWHICH)) ; BASE OF VARS FOR SECTION 474 ;I '$D(@ZZGN@(0)) Q ; NO VARS FOR THIS SECTION 475 I $O(@ZZGN@(""),-1)="" D ; 476 E D ; VARS EXIST 477 . N ZGVI,ZGVN 478 . S ZGVN=$O(@ZZGN@(""),-1) ;COUNT OF VARS 479 . F ZGVI=1:1:ZGVN D ; FOR EACH MULTIPLE IN SECTION 480 . . K ZZGA N ZZGA ; TEMP ARRAY FOR SECTION VARS 481 . . K ZZGN2 N ZZGN2 ; NAME FOR MULTIPLE 482 . . S ZZGN2=$NA(@ZZGN@(ZGVI)) 483 . . I $G(DEBUG)'="" W ZZGN2,!,$O(@ZZGN2@("")),! 484 . . D H2ARY^C0CXPATH("ZZGA",ZZGN2,ZGVI) ; CONVERT HASH TO ARRAY 485 . . ; D PARY^C0CXPATH("ZZGA") 486 . . D PUSHA^C0CXPATH("RTN","ZZGA") ; PUSH ARRAY INTO RETURN 487 Q 488 ; 489 DPATV(DFN,IWHICH) ; DISPLAY VARS FOR PATIENT DFN THAT ARE MAINTAINED IN C0CRIM 490 ; ALONG WITH SAMPLE VALUES. 491 ; IWHICH IS "ALL","MEDS","VITALS","PROBLEMS","ALERTS","RESULTS","HEADER" 492 N GTMP 493 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 494 . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES 495 I '$D(IWHICH) S IWHICH="ALL" 496 D RPCGV(.GTMP,DFN,IWHICH) 497 D PARY^C0CXPATH("GTMP") 498 Q 499 ; 500 RIM2RNF(R2RTN,DFN,RWHICH) ; CONVERTS RIM VARIABLES TO RNF2 FORMAT 501 ; RETURN IN R2RTN, WHICH IS PASSED BY NAME 502 ; RWHICH IS RIM SECTION TO RETURN, DEFAULTS TO "ALL" 503 ; 504 I '$D(RWHICH) S RWHICH="ALL" 505 ;N R2TMP 506 I '$D(^TMP("C0CRIM","ATTR",DFN)) D ; RIM VARS NOT PRESENT 507 . D ANALYZE(DFN,1) ; REFRESH THE RIM VARIABLES 508 D RPCGV(.R2TMP,DFN,RWHICH) ; RETRIEVE ALL THE VARIABLES I AN ARRAY 509 N R2I,R2J,R2X,R2X1,R2X2,R2Y,R2Z 510 F R2I=1:1:R2TMP(0) D ; FOR EVERY LINE OF THE ARRAY 511 . S R2X=$P(R2TMP(R2I),"^",1) ; OCCURANCE 512 . S R2Y=$P(R2TMP(R2I),"^",2) ; VARIABLE NAME 513 . I $L(R2Y)<4 Q ; SKIP SHORT VARIABLES (THEY ARE FOR DEBUGGING) 514 . S R2Z=$P(R2TMP(R2I),"^",3) ; VALUE 515 . I R2X[";" D ; THERES MULTIPLES 516 . . S R2X1=$P(R2X,";",1) ; FIRST INDEX 517 . . S R2X2=$P(R2X,";",2) ; SECOND INDEX 518 . . S R2J=R2Y_"["_R2X2_"]" ; BUILD THE VARIABLE NAME 519 . . S @R2RTN@("F",R2J,1)="" ; PUT VARIABLE NAME IN FIELD MAP 520 . . S @R2RTN@("V",R2X1,R2J,1)=R2Z ; PUT THE VALUE IN THE ARRAY 521 . E D ; NO SUB-MULTIPLES 522 . . S @R2RTN@("F",R2Y,1)="" ; PUT VARIABLE NAME IN FIELD MAP 523 . . S @R2RTN@("V",R2X,R2Y,1)=R2Z ; PUT THE VALUE IN THE ARRAY 524 Q 525 ; 526 RIM2CSV(DFN) ; WRITE THE RIM VARIABLES FOR A PATIENT TO A CSV FILE 527 ; 528 N R2CTMP,R2CARY 529 D RIM2RNF("R2CTMP",DFN) ; CONVERT VARIABLES TO RNF FORMAT 530 D RNF2CSV^C0CRNF("R2CARY","R2CTMP","NV") ; CONVERT RNF TO CSV FORMAT 531 D FILEOUT^C0CRNF("R2CARY","VARS-"_DFN_".csv") 532 Q 533 ; -
ccr/trunk/p/C0CRNF.m
r1331 r1336 1 C0CRNF 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 FIELDS(C0CFRTN,C0CF) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 TESTRNF 47 48 49 50 51 52 53 54 55 56 57 58 RNF1TO2(ZOUT,ZIN) 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 RNF1TO2B(ZOUT,ZIN) 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 GETNOLD(GRTN,GFILE,GIEN,GNN) 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 GETN(GRTN,GFILE,GREF,GNDX,GNN) 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 GETN1(GRTN,GFILE,GREF,GNDX,GNN) 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 ADDNV(GNV,GNVN,GNVF,GNVV) 292 293 294 295 296 297 RNF2CSV(RNRTN,RNIN,RNSTY) 298 299 300 301 302 303 304 305 306 307 308 309 310 NV(RNRTN,RNIN) 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 VN(RNRTN,RNIN) 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 READCSV(PATH,NAME,GLB) 357 358 359 360 FILE2CSV(FNUM,FVN) 361 362 363 364 365 366 367 368 369 370 371 372 373 FILEOUT(FOARY,FONAM) 374 375 376 377 378 FILEREF(FNUM) 379 380 381 382 383 384 385 386 SKIP 387 388 389 390 391 392 393 394 395 396 397 RNF2HNV(ZOUT,ZIN) 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 RNF2HVN(ZOUT,ZIN) 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 ZFILE(ZFN,ZTAB) 442 443 444 445 446 ZFIELD(ZFN,ZTAB) 447 448 449 450 451 ZVALUE(ZFN,ZTAB) 452 453 454 455 456 457 ZVALUEI(ZFN,ZTAB) 458 459 460 461 462 1 C0CRNF ; CCDCCR/GPL - Reference Name Format (RNF) utilities; 12/6/08 2 ;;1.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 FIELDS(C0CFRTN,C0CF) ; RETURNS AN ARRAY OF THE FIELDS IN FILE C0CF, 25 ; C0CFRTN IS PASSED BY NAME, C0CF IS PASSED BY VALUE 26 ; 27 N C0CFI,C0CFJ ;INNER LOOP, OUTER LOOP 28 N C0CFN ; FIELD NAME 29 S C0CFI=0 S C0CFJ=C0CF 30 K @C0CFRTN ; CLEAR THE RETURN ARRAY 31 F Q:C0CFJ'[C0CF D ; FOR THE C0CF FILE AND ALL SUBFILES INCLUSIVE 32 . ;W "1: "_C0CFJ," ",C0CFI,! 33 . F S C0CFI=$O(^DD(C0CFJ,C0CFI)) Q:+C0CFI=0 D ; EVERY FIELD 34 . . ;W "2: "_C0CFJ," ",C0CFI,! 35 . . S C0CFN=$P($G(^DD(C0CFJ,C0CFI,0)),"^",1) ;PULL FIELD NAME FROM ^DD 36 . . ;W "N: ",C0CFN,! 37 . . ;I C0CFN="STR" W C0CFN," ",C0CFJ,! 38 . . I $D(@C0CFRTN@(C0CFN)) D ; IS THIS A DUPLICATE? 39 . . . I $G(DEBUG) D ; 40 . . . . W "DUPLICATE FOUND! ",C0CFJ," ",C0CFI," ",C0CFN,!,@C0CFRTN@(C0CFN),! 41 . . . S @C0CFRTN@(C0CFN_"_"_C0CFJ)=C0CFJ_"^"_C0CFI 42 . . E S @C0CFRTN@(C0CFN)=C0CFJ_"^"_C0CFI 43 . S C0CFJ=$O(^DD(C0CFJ)) ; NEXT SUBFILE 44 Q 45 ; 46 TESTRNF ; TEST THE RNF1TO2 ROUTINE 47 S G1("ONE")=1 48 S G1("TWO")=2 49 S G1("THREE")=3 50 D RNF1TO2("GPL","G1") 51 S G1("ONE")="NOT1" 52 S G1("TWO")="STILL2" 53 S G1("THREE")=3 54 D RNF1TO2("GPL","G1") 55 ZWR GPL 56 Q 57 ; 58 RNF1TO2(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 59 ; (ZOUT) BOTH ARE PASSED BY NAME 60 ; RNF1 IS OF THE FORM: 61 ; @ZIN@("VAR1")=VAL1 62 ; @ZIN@("VAR2")=VAL2 63 ; RNF2 IS OF THE FORM: 64 ; @ZOUT@("F","VAR1")="" 65 ; @ZOUT@("F","VAR2")="" 66 ; @ZOUT@("V",n,"VAR1")=VAL1 67 ; @ZOUT@("V",n,"VAR2")=VAL2 68 ; WHERE n IS THE "ROW" OF THE ARRAY 69 N ZI S ZI="" 70 N ZN 71 I '$D(@ZOUT@("V",1)) S ZN=1 72 E S ZN=$O(@ZOUT@("V",""),-1)+1 73 F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; 74 . S @ZOUT@("F",ZI)="" 75 . S @ZOUT@("V",ZN,ZI)=@ZIN@(ZI) 76 Q 77 ; 78 RNF1TO2B(ZOUT,ZIN) ; ADDS AN RNF1 ARRAY (ZIN) TO THE END OF AN RNF2 ARRAY 79 ; THE "B" ROUTINE SUPPORTS WP FIELDS IN THE ARRAY 80 ; EVERY "V" VARIABLE IS FOLLOWED BY A "1" 81 ; FOR EXAMPLE @G@("V",n,"VAR1",1)="VALUE1" 82 ; USE THIS ROUTINE IF YOU WANT TO CONVERT THE RESULT TO A CSV 83 ; WITH RNF2CSV 84 ; (ZOUT) BOTH ARE PASSED BY NAME 85 ; RNF1 IS OF THE FORM: 86 ; @ZIN@("VAR1")=VAL1 87 ; @ZIN@("VAR2")=VAL2 88 ; RNF2 IS OF THE FORM: 89 ; @ZOUT@("F","VAR1")="" 90 ; @ZOUT@("F","VAR2")="" 91 ; @ZOUT@("V",n,"VAR1",1)=VAL1 92 ; @ZOUT@("V",n,"VAR2",1)=VAL2 93 ; WHERE n IS THE "ROW" OF THE ARRAY 94 N ZI S ZI="" 95 N ZN 96 I '$D(@ZOUT@("V",1)) S ZN=1 97 E S ZN=$O(@ZOUT@("V",""),-1)+1 98 F S ZI=$O(@ZIN@(ZI)) Q:ZI="" D ; 99 . S @ZOUT@("F",ZI)="" 100 . S @ZOUT@("V",ZN,ZI,1)=@ZIN@(ZI) 101 Q 102 ; 103 GETNOLD(GRTN,GFILE,GIEN,GNN) ; GET FIELDS FOR ACCESS BY NAME 104 ; GRTN IS PASSED BY NAME 105 ; 106 N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 107 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 108 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 109 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 110 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 111 D GETS^DIQ(GFILE,C0CREF,"**","I","C0CTMP") 112 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 113 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J ; STRUCTURE SIGNATURE 114 S (C0CI,C0CJ)="" 115 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 116 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 117 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 118 . . ;W C0CJ," ",C0CI,! 119 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 120 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI) ; 121 . . I C0CVALUE["C0CTMP" S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,1) ;1ST LINE OF WP 122 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 123 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 124 . S C0CI="" 125 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 126 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 127 Q 128 ; 129 GETN(GRTN,GFILE,GREF,GNDX,GNN) ; GET BY NAME ; RETURN A FIELD VALUE MAP 130 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 131 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 132 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN 133 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 134 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 135 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 136 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 137 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 138 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 139 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 140 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 141 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 142 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 143 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 144 ; GREF IS THE VALUE FOR THE INDEX 145 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 146 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 147 ; 148 ; 149 N GIEN,GF 150 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE 151 I ('$D(GNDX))!($G(GNDX)="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN 152 E D ; WE ARE USING AN INDEX 153 . ;N ZG 154 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX 155 . I ZG'="" D ; 156 . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? 157 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN 158 . . E S GIEN="" ; NOT FOUND IN INDEX 159 . E S GIEN="" ; 160 ;W "IEN: ",GIEN,! 161 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 162 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 163 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 164 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 165 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 166 K C0CTMP 167 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") 168 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 169 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE 170 S (C0CI,C0CJ)="" 171 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 172 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 173 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 174 . . ;W C0CJ," ",C0CI,! 175 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 176 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; 177 . . I C0CVALUE["C0CTMP" D ; WP FIELD 178 . . . N ZT,ZWP S ZWP=0 ;ITERATOR 179 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE 180 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE 181 . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; 182 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP 183 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " 184 . . . . S C0CVALUE=C0CVALUE_ZT ; 185 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 186 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) 187 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 188 . S C0CI="" 189 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 190 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 191 Q 192 ; 193 GETN1(GRTN,GFILE,GREF,GNDX,GNN) ; NEW GET ;GPL ; RETURN A FIELD VALUE MAP 194 ; THE FOLLOWING COMMENTS ARE WRONG.. THIS ROUTINE STILL RETURNS AN RNF1 195 ; FORMAT ARRAY @GRTN@("FIELD NAME")="FILE^FIELD#^VALUE" ;GPL 196 ; GETN IS AN EXTRINSIC WHICH RETURNS THE NEXT IEN AFTER THE CURRENT GIEN 197 ; GRTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 198 ; .. FIELD MAP @GRTN@("F","FIELDNAME^FILE^FIELD#")="" 199 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 200 ; .. VALUE MAP @GRTN@("V","IEN","FIELDNAME")=VALUE 201 ; .. GRTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 202 ; .. IF GNN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 203 ; .. EVEN IF GNN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 204 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 205 ; IF GREF IS "" THE FIRST RECORD IS OBTAINED 206 ; IF GNDX IS NULL, GREF IS AN IEN FOR THE FILE 207 ; GNDX IS THE INDEX TO USE TO OBTAIN THE IEN 208 ; GREF IS THE VALUE FOR THE INDEX 209 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 210 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GRTN 211 ; 212 ; 213 N GIEN,GF 214 S GF=$$FILEREF(GFILE) ;CLOSED FILE REFERENCE FOR FILE NUMBER GFILE 215 I ('$D(GNDX))!(GNDX="") S GIEN=GREF ; IF NO INDEX USED, GREF IS THE IEN 216 E D ; WE ARE USING AN INDEX 217 . ;N ZG 218 . S ZG=$Q(@GF@(GNDX,GREF)) ;ACCESS INDEX 219 . I ZG'="" D ; 220 . . I $QS(ZG,3)=GREF D ; IS GREF IN INDEX? 221 . . . S GIEN=$QS(ZG,4) ; PULL OUT THE IEN 222 . . E S GIEN="" ; NOT FOUND IN INDEX 223 . E S GIEN="" ; 224 ;W "IEN: ",GIEN,! 225 ;N C0CTMP,C0CI,C0CJ,C0CREF,C0CNAME 226 I $D(GNN) I GNN="ALL" S C0CNN=0 ; NOT NON-NULL (ALL FIELDS TO BE RETURNED) 227 E S C0CNN=1 ; NON-NULL IS TRUE (ONLY POPULATED FIELDS RETURNED) 228 S C0CREF=GIEN_"," ; OPEN ROOT REFERENCE INTO FILE 229 D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 230 K C0CTMP 231 D GETS^DIQ(GFILE,C0CREF,"**","IE","C0CTMP") 232 D FIELDS(GRTN,GFILE) ;GET ALL THE FIELD NAMES FOR THE FILE 233 S @GRTN@(0)=GFILE_"^RNF1^"_GIEN_"^"_DT_"^"_$J_"^"_DUZ ; STRUCTURE SIGNATURE 234 S (C0CI,C0CJ)="" 235 F S C0CJ=$O(C0CTMP(C0CJ)) Q:C0CJ="" D ; FOR ALL SUBFILES 236 . S C0CREF=$O(C0CTMP(C0CJ,"")) ; RECORD REFERENCE 237 . F S C0CI=$O(C0CTMP(C0CJ,C0CREF,C0CI)) Q:C0CI="" D ; ARRAY OF FIELDS 238 . . ;W C0CJ," ",C0CI,! 239 . . S C0CNAME=$P(^DD(C0CJ,C0CI,0),"^",1) ;PULL THE FIELD NAME 240 . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,"E") ; 241 . . I C0CVALUE["C0CTMP" D ; WP FIELD 242 . . . N ZT,ZWP S ZWP=0 ;ITERATOR 243 . . . S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) ; INIT TO FIRST LINE 244 . . . S C0CVALUE=C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ; INIT TO FIRST LINE 245 . . . F S ZWP=$O(C0CTMP(C0CJ,C0CREF,C0CI,ZWP)) Q:'ZWP D ; 246 . . . . S ZT=" "_C0CTMP(C0CJ,C0CREF,C0CI,ZWP) ;LINE OF WP 247 . . . . S ZT=$TR(ZT,"^""","|'") ;HACK TO GET RID OF ^ AND " IN TEXT " 248 . . . . S C0CVALUE=C0CVALUE_ZT ; 249 . . S $P(@GRTN@(C0CNAME),"^",3)=C0CVALUE ;RETURN VALUE IN P3 250 . . S $P(@GRTN@(C0CNAME,"I"),"^",3)=$G(C0CTMP(C0CJ,C0CREF,C0CI,"I")) 251 I C0CNN D ; IF ONLY NON-NULL VALUES ARE TO BE RETURNED 252 . S C0CI="" 253 . F S C0CI=$O(@GRTN@(C0CI)) Q:C0CI="" D ; GO THROUGH THE WHOLE ARRAY 254 . . I $P(@GRTN@(C0CI),"^",3)="" K @GRTN@(C0CI) ; KILL THE NULL ENTRIES 255 Q 256 ; 257 GETN2(GARTN,GAFILE,GAIDX,GACNT,GASTRT,GANN) ; RETURN FIELD MAP AND VALUES 258 ; GARTN, PASSED BY NAME, RETURNS A FIELD MAP AND A VALUE MAP 259 ; .. FIELD MAP @GARTN@("F","FIELDNAME")="FILE;FIELD#" 260 ; ... ANY FIELD USED BY ANY RECORD PROCESSED IS IN THE FIELD MAP 261 ; .. VALUE MAP @GARTN@("V","IEN","FIELDNAME","N")=VALUE 262 ; .. WHERE N IS THE INDEX FOR MULTIPLES.. 1 FOR SINGLE VALUES 263 ; .. GARTN IS NOT INITIALIZED, SO MULTIPLE CALLS ARE CUMULATIVE 264 ; .. IF GANN="ALL" THEN ALL FIELDS FOR THE FILE ARE IN THE FIELD MAP 265 ; .. EVEN IF GANN="ALL" ONLY POPULATED FIELDS ARE RETURNED IN THE VALUE MAP 266 ; .. NUL FIELDS CAN BE DETERMINED BY CHECKING FIELD MAP - THIS SAVES SPACE 267 ; GAFILE IS THE FILE NUMBER TO BE PROCESSED. IT IS PASSED BY VALUE 268 ; GAIDX IS THE OPTIONAL INDEX TO USE IN THE FILE. IF GAIDX IS "" THE IEN 269 ; .. OF THE FILE WILL BE USED 270 ; GACNT IS THE NUMBER OF RECORDS TO PROCESS. IT IS PASSED BY VALUE 271 ; .. IF GARCNT IS NULL, ALL RECORDS ARE PROCESSED 272 ; GASTRT IS THE IEN OF THE FIRST RECORD TO PROCESS. IT IS PASSED BY VALUE 273 ; .. IF GARSTART IS NULL, PROCESSING STARTS AT THE FIRST RECORD 274 ; GANN= NOT NULL - IF GANN IS "ALL" THEN EVEN NULL FIELDS WILL BE RETURNED 275 ; OTHERWISE, ONLY POPULATED FIELDS ARE RETURNED IN GARFLD AND GARVAL 276 ;N GATMP,GAI,GAF 277 S GAF=$$FILEREF(GAFILE) ; GET CLOSED ROOT FOR THE FILE NUMBER GAFILE 278 I '$D(GAIDX) S GAIDX="" ;DEFAULT 279 I '$D(GANN) S GANN="" ;DEFAULT ONLY POPULATED FIELDS RETURNED 280 I GAIDX'="" S GAF=$NA(@GAF@(GAIDX)) ; IF WE ARE USING AN INDEX 281 W GAF,! 282 W $O(@GAF@(0)) ; 283 S GAI=0 ;ITERATOR 284 F S GAI=$O(@GAF@(GAI)) Q:GAI="" D ; 285 . D GETN1("GATMP",GAFILE,GAI,GAIDX,GANN) ;GET ONE RECORD 286 . N GAX S GAX=0 287 . F S GAX=$O(GATMP(GAX)) Q:GAX="" D ;PULL OUT THE FIELDS 288 . . D ADDNV(GARTN,GAI,GAX,GATMP(GAX)) ;INSERT THE NAME/VALUE INTO GARTN 289 Q 290 ; 291 ADDNV(GNV,GNVN,GNVF,GNVV) ; CREATE AN ELEMENT OF THE MATRIX 292 ; 293 S @GNV@("F",GNVF)=$P(GNVV,"^",1)_"^"_$P(GNVV,"^",2) ;NAME=FILE^FIELD# 294 S @GNV@("V",GNVN,GNVF,1)=$P(GNVV,"^",3) ;SET THE VALUE 295 Q 296 ; 297 RNF2CSV(RNRTN,RNIN,RNSTY) ;CONVERTS AN RFN2 GLOBAL TO A CSV FORMAT 298 ; READY TO WRITE FOR USE WITH EXCEL @RNRTN@(0) IS NUMBER OF LINES 299 ; RNSTY IS STYLE OF THE OUTPUT - 300 ; .. "NV"= ROWS ARE NAMES, COLUMNS ARE VALUES 301 ; .. "VN"= ROWS ARE VALUES, COLUMNS ARE NAMES 302 ; .. DEFAULT IS "NV" BECAUSE MANY MATRICES HAVE MORE FIELDS THAN VALUES 303 N RNR,RNC ;ROW ROOT,COL ROOT 304 N RNI,RNJ,RNX 305 I '$D(RNSTY) S RNSTY="NV" ;DEFAULT 306 I RNSTY="NV" D NV(RNRTN,RNIN) ; INTERNAL SUBROUTINES DEPENDING ON ORIENTATION 307 E D VN(RNRTN,RNIN) ; 308 Q 309 ; 310 NV(RNRTN,RNIN) ; 311 S RNR=$NA(@RNIN@("F")) 312 S RNC=$NA(@RNIN@("V")) 313 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 314 S RNX="""FILE"""_"," ; FIRST COLUMN NAME IS "FIELD" 315 S RNI="" 316 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 317 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 318 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 319 D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 320 S RNI="" 321 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 322 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 323 . S RNJ="" 324 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 325 . . I $D(@RNC@(RNJ,RNI,1)) D ; THIS ROW HAS THIS COLUMN 326 . . . S RNX=RNX_""""_@RNC@(RNJ,RNI,1)_""""_"," ; ADD THE ELEMENT PLUS A COMMA 327 . . E S RNX=RNX_"," ; NUL COLUMN 328 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 329 . D PUSH^C0CXPATH(RNRTN,RNX) 330 Q 331 ; 332 VN(RNRTN,RNIN) ; 333 S RNR=$NA(@RNIN@("V")) 334 S RNC=$NA(@RNIN@("F")) 335 ;S RNY=$P(@RNIN@(0),"^",1) ; FILE NUMBER 336 S RNX="""ROW"""_"," ; FIRST COLUMN NAME IS "ROW" 337 S RNI="" 338 F S RNI=$O(@RNC@(RNI)) Q:RNI="" D ; FOR EACH COLUMN 339 . S RNX=RNX_RNI_"," ;ADD THE COLUMM ELEMENT AND A COMMA 340 S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 341 D PUSH^C0CXPATH(RNRTN,RNX) ; FIRST LINE CONTAINS COLUMN HEADINGS 342 S RNI="" 343 F S RNI=$O(@RNR@(RNI)) Q:RNI="" D ; FOR EACH ROW 344 . S RNX=""""_RNI_""""_"," ; FIRST ELEMENT ON ROW IS THE FIELD 345 . S RNJ="" 346 . F S RNJ=$O(@RNC@(RNJ)) Q:RNJ="" D ; FOR EACH COL 347 . . I $D(@RNR@(RNI,RNJ,1)) D ; THIS ROW HAS THIS COLUMN 348 . . . S RNV=$TR(@RNR@(RNI,RNJ,1),"""","") 349 . . . S RNV=$TR(RNV,",","") 350 . . . S RNX=RNX_""""_RNV_""""_"," ; ADD THE ELEMENT PLUS A COMMA 351 . . E S RNX=RNX_"," ; NUL COLUMN 352 . S RNX=$E(RNX,1,$L(RNX)-1) ; STRIP OFF THE LAST COMMA 353 . D PUSH^C0CXPATH(RNRTN,RNX) 354 Q 355 ; 356 READCSV(PATH,NAME,GLB) ; READ A CSV FILE IN FROM UNIX TO GLB, PASSED BY NAME 357 ; 358 Q $$FTG^%ZISH(PATH,NAME,GLB,1) 359 ; 360 FILE2CSV(FNUM,FVN) ; WRITES OUT A FILEMAN FILE TO CSV 361 ; 362 ;N G1,G2 363 I '$D(FVN) S FVN="NV" ; DEFAULT ORIENTATION OF CVS FILE 364 S G1=$NA(^TMP($J,"C0CCSV",1)) 365 S G2=$NA(^TMP($J,"C0CCSV",2)) 366 D GETN2(G1,FNUM) ; GET THE MATRIX 367 D RNF2CSV(G2,G1,FVN) ; PREPARE THE CVS FILE 368 K @G1 369 D FILEOUT(G2,"FILE_"_FNUM_".csv") 370 K @G2 371 Q 372 ; 373 FILEOUT(FOARY,FONAM) ; WRITE OUT A FILE 374 ; 375 W $$OUTPUT^C0CXPATH($NA(@FOARY@(1)),FONAM,^TMP("C0CCCR","ODIR")) 376 Q 377 ; 378 FILEREF(FNUM) ; EXTRINSIC THAT RETURNS A CLOSED ROOT FOR FILE NUMBER FNUM 379 ; 380 N C0CF 381 S C0CF=^DIC(FNUM,0,"GL") ;OPEN ROOT TO FILE 382 S C0CF=$P(C0CF,",",1)_")" ; CLOSE THE ROOT 383 I C0CF["()" S C0CF=$P(C0CF,"()",1) 384 Q C0CF 385 ; 386 SKIP ; 387 N TXT,DIERR 388 S TXT=$$GET1^DIQ(8925,TIUIEN,"2","","TXT") 389 I $D(DIERR) D CLEAN^DILF Q 390 W " report_text:",! ;Progress Note Text 391 N LN S LN=0 392 F S LN=$O(TXT(LN)) Q:'LN D 393 . W " text"_LN_": "_TXT(LN),! 394 . Q 395 Q 396 ; 397 RNF2HNV(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME 398 ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT 399 ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END 400 ; THE TABLE WILL BE IN NV FORMAT, ROWS ARE NAMES COLUMNS ARE VALUES 401 D PUSH^C0CXPATH(ZOUT,"<table border=""1"">") 402 N ZI,ZJ,ZV,ZN S ZI="" S ZJ=0 403 D PUSH^C0CXPATH(ZOUT,"<tr><td></td>") ;begin row and leave a blank col 404 F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE 405 . S ZV="<td>"_ZJ_"</td>" ; OCCURANCE AS COLUMNS HEADER 406 . D PUSH^C0CXPATH(ZOUT,ZV) 407 D PUSH^C0CXPATH(ZOUT,"</tr>") ;end of first row 408 S ZI="" 409 F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 410 . S ZN="<tr><td>"_ZI_"</td>" ; VARIABLE NAME IN FIRST COLUMN 411 . D PUSH^C0CXPATH(ZOUT,ZN) 412 . S ZJ=0 ;RESET TO DO IT AGAIN 413 . F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH OCCURANCE 414 . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" 415 . . D PUSH^C0CXPATH(ZOUT,ZV) 416 . D PUSH^C0CXPATH(ZOUT,"</tr>") ;END OF ROW 417 D PUSH^C0CXPATH(ZOUT,"</table>") ; end of table 418 Q 419 ; 420 RNF2HVN(ZOUT,ZIN) ;RETURN AN HTML TABLE IN ZOUT, PASSED BY NAME 421 ; OF ZIN, WHICH IS PASSED BY NAME AND IS IN RNF2 FORMAT 422 ; ZOUT IS NOT INITIALIZED, SO THE TABLE WILL GO AT THE END 423 ; THE TABLE WILL BE IN VN FORMAT, ROWS ARE VALUES COLUMNS ARE NAMES 424 D PUSH^C0CXPATH(ZOUT,"<table border=""1"">") 425 N ZI,ZJ S ZI="" S ZJ=0 426 D PUSH^C0CXPATH(ZOUT,"<tr>") ;new row for column headers 427 F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 428 . S ZV="<td>"_ZI_"</td>" 429 . D PUSH^C0CXPATH(ZOUT,ZV) ; name 430 D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header row 431 S ZI="" ;RESET TO DO AGAIN 432 F S ZJ=$O(@ZIN@("V",ZJ)) Q:+ZJ=0 D ; FOR EACH ROW OF VARIABLES 433 . D PUSH^C0CXPATH(ZOUT,"<tr>") ;begin row 434 . F S ZI=$O(@ZIN@("F",ZI)) Q:ZI="" D ; FOR EACH VARIABLE 435 . . S ZV="<td>"_$G(@ZIN@("V",ZJ,ZI,1))_"</td>" ; value 436 . . D PUSH^C0CXPATH(ZOUT,ZV) ; value 437 . D PUSH^C0CXPATH(ZOUT,"</tr>") ; end header 438 D PUSH^C0CXPATH(ZOUT,"</table>") ;end of table 439 Q 440 ; 441 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 442 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF @ZTAB@(ZFN) 443 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 444 I '$D(ZTAB) S ZTAB="C0CA" 445 Q $P(@ZTAB@(ZFN),"^",1) 446 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 447 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF @ZTAB@(ZFN) 448 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 449 I '$D(ZTAB) S ZTAB="C0CA" 450 Q $P(@ZTAB@(ZFN),"^",2) 451 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 452 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 453 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 454 I '$D(ZTAB) S ZTAB="C0CA" 455 Q $P($G(@ZTAB@(ZFN)),"^",3) 456 ; 457 ZVALUEI(ZFN,ZTAB) ;EXTRINSIC TO RETURN INTERNAL VALUE FOR FIELD NAME PASSED 458 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF @ZTAB@(ZFN) 459 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 460 I '$D(ZTAB) S ZTAB="C0CA" 461 Q $P($G(@ZTAB@(ZFN,"I")),"^",3) 462 ; -
ccr/trunk/p/C0CRXN.m
r1331 r1336 1 C0CRXN 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXPAND 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 EXP2 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 CHKNDF 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 SETFDA(C0CSN,C0CSV) 256 257 258 259 260 261 262 263 264 265 ZFILE(ZFN,ZTAB) 266 267 268 269 270 271 272 273 ZFIELD(ZFN,ZTAB) 274 275 276 277 278 279 280 281 282 ZVALUE(ZFN,ZTAB) 283 284 285 286 287 288 289 290 1 C0CRXN ; CCDCCR/GPL - CCR RXN utilities; 12/6/08 2 ;;1.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 EXPAND ; MAIN ROUTINE TO CREATE THE C0C RXNORM VUID EXPANSION FILE (176.112) 25 ; READ EACH RECORD FROM 176.111 AND USE THE VUID TO LOOK UP THE RXNORM 26 ; CODE FROM 176.001 (RXNORM CONCEPTS) 27 ; POPULATE ALL FIELDS IN 176.112 AND SET "NEW" TO "Y" IF 176.111 DOES NOT 28 ; ALREADY HAVE AN RXNORM CODE. 29 ; ADD THE RXNORM TEXT FIELD TO EVERY RECORD (NOT PRESENT IN 176.111) 30 ; AND COMPARE THE RXNORM TEXT FIELD WITH THE VUID TEXT FIELD, SETTING THE 31 ; "DIFFERENT TEXT" FIELD TO "Y" IF THERE ARE DIFFERENCES 32 ; USES SUPPORT ROUTINES FROM C0CRNF.m 33 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 34 N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES 35 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 36 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 37 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 38 S C0CF=$$FILEREF^C0CRNF(176.112) ; C0C RXNORM VUID MAPPING EXPANSION FILE 39 W C0CVA,C0CFRXN,C0CF,! 40 S C0CZX=0 41 S (HASRXN,NORXN,NOVUID,RXFOUND,RXMATCH,TXTMATCH)=0 ; INITIALIZE COUNTERS 42 F S C0CZX=$O(^C0CCODES(176.111,C0CZX)) Q:+C0CZX=0 D ; FOR EVERY RECORD 43 . K C0CA,C0CB,C0CC ; CLEAR ARRAYS 44 . D FIELDS^C0CRNF("C0CC",176.112) ;GET FIELD NAMES FOR OUTPUT FILE 45 . D GETN1^C0CRNF("C0CA",176.111,C0CZX,"","ALL") ;GET THE FIELDS 46 . I $$ZVALUE("MEDIATION CODE")="" D 47 . . S NORXN=NORXN+1 ; 48 . E D ; PROCESS MEDIATION CODE 49 . . S HASRXN=HASRXN+1 50 . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ; 51 . I $$ZVALUE("VUID")="" D ; BAD RECORD 52 . . S NOVUID=NOVUID+1 53 . . ;D SETFDA("VUID",$$ZVALUE("VUID")) 54 . E D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT")) 55 . . ;ZWR C0CA 56 . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL") 57 . I $$ZVALUE("RXCUI","C0CB")'="" D ; RXNORM FOUND 58 . . S RXFOUND=RXFOUND+1 59 . . I $$ZVALUE("MEDIATION CODE")="" D ; THIS IS A NEW CODE 60 . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB")) 61 . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM 62 . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),! 63 . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),! 64 . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1 65 . . E D ; 66 . . . S ZZ=$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB") 67 . . . D PUSH^GPLXPATH("NOMATCH",ZZ) 68 . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ; 69 . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT 70 . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D ; 71 . . S RXMATCH=RXMATCH+1 72 . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),! 73 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 74 . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD 75 . D UPDATE^DIE("","C0CFDA") 76 . I $D(^TMP("DIERR",$J)) U $P BREAK 77 W "HAS RXN=",HASRXN,! 78 W "NO RXN=",NORXN,! 79 W "NO VUID=",NOVUID,! 80 W "RXNORM FOUND=",RXFOUND,! 81 W "RXNORM MATCHES:",RXMATCH,! 82 W "TEXT MATCHES:",TXTMATCH,! 83 Q 84 ; 85 EXP2 ; ROUTINE TO CREATE 176.113 C0C RXNORM VUID MAPPING DISCREPANCIES FILE 86 ; CROSS CHECKS THE NATIONAL DRUG FILE AND THE VA MAPPING FILE AGAINST 87 ; THE UMLS RXNORM DATABASE 88 ; THIS ROUTINE HAS BEEN ENHANCED TO ALSO CHECK THE 50.416 DRUG INGREDIENT 89 ; FILE AND TREAT VUIDS FOUND THERE LIKE THE ONES BEING FOUND IN THE NDF 90 ; IF THE VUID EXISISTS IN ALL THREE FILES, THE RXNORM CODE MATCHES IN 91 ; THE VA MAPPING FILE AND THE TEXT STRINGS ARE THE SAME, THE VUID IS INCLUDED 92 ; IN THE FILE BUT NO FLAGS ARE SET 93 ; IF THE VUID IS MISSING FROM THE NATIONAL DRUG FILE NDF=N 94 ; (IF THE VUID IS MISSING FROM THE NDF, IT IS CHECKED IN THE DRUG INGREDIENT 95 ; FILE, AND IF FOUND, THE FLAG IS NOT SET. IN THIS CASE THE TEXT FROM THE 96 ; DRUG INGREDIENT FILE IS USED FOR COMPARISONS) 97 ; IF THE VUID IS MISSING FROM THE VA MAPPING FILE VAMAP=N 98 ; IF THE VUID IS PRESENT IN THE VA MAPPING FILE, BUT THE RXNORM 99 ; CODE IS MISSING IN THAT FILE, VARXN=N 100 ; IF THE TEXT STRINGS DO NOT MATCH EXACTLY, TXTM=N AND ALL THREE STRINGS 101 ; ARE SHOWN; NDF TEXT=NDF TEXT STRING, VA MAP TEXT=VA MAPPING TEXT STRING 102 ; RXNORM TEXT=RXNORM TEXT STRING 103 ; THE FILE IS KEYED ON VUID AND WOULD USUALLY BE SORTED BY VUID 104 ; THE OBJECTIVE IS TO SEE IF NDF (50.68) AND VA MAPPING (176.111) HAVE 105 ; ALL THE VUID CODES THAT ARE IN THE UMLS RXNORM DATABASE 106 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 107 N C0CFVA,C0CFRXN ; CLOSED ROOTS FOR SOURCE FILES 108 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 109 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 110 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 111 ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE 112 W C0CVA,C0CFRXN,! ;C0CF,! 113 S C0CZX=0 114 S (NDFVCNT,NDFTCNT,NDFNO)=0 ; COUNTERS FOR NDF TESTS 115 S (VAVCNT,VATCNT,VARCNT,VANO)=0 ; COUNTERS FOR VA MAPPING FILE TESTS 116 F S C0CZX=$O(^C0CRXN(176.001,"VUID",C0CZX)) Q:+C0CZX=0 D ; FOR EVERY VUID 117 . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS 118 . D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE 119 . D GETN1^C0CRNF("C0CA",176.001,C0CZX,"VUID","ALL") ;GET FROM RXNORM FILE 120 . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;GET FROM VA MAPPING FILE 121 . D GETN1^C0CRNF("C0CD",50.68,C0CZX,"AVUID","ALL") ;GET FROM NDF 122 . D GETN1^C0CRNF("C0CE",50.416,C0CZX,"AVUID","ALL") ;GET FROM DRUG INGREDIENTS 123 . ;D SETFDA("VUID",$$ZVALUE("CODE")) ;SET THE VUID CODE 124 . D SETFDA("RXNORM",$$ZVALUE("RXCUI")) ;SET THE RXNORM CODE 125 . D SETFDA("RXNORM TEXT",$$ZVALUE("STR")) ;SET THE RXNORM TEXT 126 . ;VA MAPPING FILE TESTS 127 . I $$ZVALUE("VUID","C0CB")=C0CZX D ; VUID FOUND 128 . . S VAVCNT=VAVCNT+1 ;INCREMENT COUNT 129 . . I $$ZVALUE("STR")'=$$ZVALUE("VUID TEXT","C0CB") D ;TEXT MISMATCH 130 . . . S VATCNT=VATCNT+1 ; INCREMENT VA TEXT MISMATCH COUNT 131 . . . D SETFDA("TXTM","N") ;MARK THAT TEXT DOESN'T MATCH 132 . . . D SETFDA("VA MAP TEXT",$$ZVALUE("VUID TEXT","C0CB")) ; SET VA MAP TEXT 133 . E D ; VUID NOT FOUND 134 . . S VANO=VANO+1 135 . . D SETFDA("VAMAP","N") ;MARK AS MISSING FROM VA MAPPING FILE 136 . ; NATIONAL DRUG FILE TESTS 137 . I ($$ZVALUE("VUID","C0CD")=C0CZX)!($$ZVALUE("VUID","C0CE")=C0CZX) D ; 138 . . ;FOUND IN NATIONAL DRUG FILE OR DRUG INGREDIENT FILE 139 . . S NDFVCNT=NDFVCNT+1 ;INCREMENT VUID FOUND COUNT 140 . . I $$ZVALUE("NAME","C0CD")'=$$ZVALUE("STR") D ;NDF TEXT DOESN'T MATCH 141 . . . I $$ZVALUE("NAME","C0CE")'=$$ZVALUE("STR") D ;DRUG ING FILE ALSO 142 . . . . S NDFTCNT=NDFTCNT+1 ; INCREMENT MISMATCHED NDF TEXT COUNT 143 . . . . D SETFDA("TXTM","N") ; SET TEXT MATCH FLAG TO N 144 . . . . D SETFDA("NDF TEXT",$$ZVALUE("NAME","C0CD")) ;POST THE TEXT 145 . . . . D SETFDA("NAT DRUG TEXT",$$ZVALUE("NAME","C0CE")) ;POST TEXT 146 . E D ; 147 . . D SETFDA("NDF","N") ;MARK AS MISSING 148 . . S NDFNO=NDFNO+1 ;INCREMENT MISSING COUNT 149 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 150 . S C0CFDA(176.113,"+"_C0CZX_",",.01)=C0CZX ; NEW VUID RECORD 151 . D UPDATE^DIE("","C0CFDA") 152 . I $D(^TMP("DIERR",$J)) U $P BREAK 153 W "VA MAPPING VUID COUNT: ",VAVCNT,! 154 W "VA MAPPING MISSING: ",VANO,! 155 W "VA MAPPING TEXT MISMATCH: ",VATCNT,! 156 W "NDF VUID COUNT: ",NDFVCNT,! 157 W "NDF MISSING: ",NDFNO,! 158 W "NDF TEXT MISMATCH: ",NDFTCNT,! 159 Q 160 CHKNDF ; ROUTINE TO CHECK THE NATIONAL DRUG FILE WITH THE UMLS RXNORM DB 161 ; USING THE AVUID INDEX, READS ALL VUID CODES IN ^PSNDF(50.68), 162 ; CHECKS TO SEE IF THE CODE IS IN 176.001, AND CREATES A RECORD 163 ; IN 176.114 164 ; THE OBJECTIVE IS TO SEE IF ^PSNDF(50.68) HAS ALL THE VUID CODES IN THE 165 ; UMLS RXNORM DATABASE AND IF THE TEXT FIELDS MATCH 166 ; ALSO CAPTURES THE RXNORM CODE MAPPING 167 ; CHKNDF2 WILL CHECK THE OTHER DIRECTION, STARTING WITH THE 176.001 VUID INDEX 168 ; THIS ROUTINE ALSO CHECKS IF THE VUID CODE IS IN 176.111 AND IF NOT 169 ; SETS NOTMAPPED=Y 170 N C0CFDA,C0CA,C0CB,C0CC,C0CZX ;FDA WORK ARRAY, RNF ARRAYS, AND IEN ITERATOR 171 N C0CFVA,C0CFRXN,C0CPSNDF ; CLOSED ROOTS FOR SOURCE FILES 172 N C0CF ; CLOSED ROOT FOR DESTINATION FILE 173 S C0CPSNDF=$$FILEREF^C0CRNF(50.68) ; NDF CLOSED ROOT REFERENCE 174 S C0CVA=$$FILEREF^C0CRNF(176.111) ; C0C PHARMACY VA RXNORM MAPPING FILE 175 S C0CFRXN=$$FILEREF^C0CRNF(176.001) ; CLOSED ROOT FOR RXNORM CONCEPT FILE 176 ;S C0CF=$$FILEREF^C0CRNF(176.113) ; C0C RXNORM VUID MAPPING ADDITIONAL FILE 177 W C0CVA,C0CFRXN,! ;C0CF,! 178 S C0CZX=0 179 S (FOUND,MISSING)=0 180 S (NOVUID,VMATCH,NOMATCH,MISSING,FOUND,TXTMATCH,NOTM,NVAM)=0 ; COUNTERS 181 F S C0CZX=$O(^PSNDF(50.68,"AVUID",C0CZX)) Q:+C0CZX=0 D ; FOR EVERY VUID 182 . K C0CA,C0CB,C0CC,C0CD ; CLEAR ARRAYS 183 . ;D FIELDS^C0CRNF("C0CC",176.113) ;GET FIELD NAMES FOR OUTPUT FILE 184 . D GETN1^C0CRNF("C0CA",50.68,C0CZX,"AVUID","ALL") ;GET THE FIELDS 185 . I $$ZVALUE("VUID")="" D ; ERROR, SHOULD NOT HAPPEN 186 . . S NOVUID=NOVUID+1 ; FLAG THE ERROR 187 . . D PUSH^GPLXPATH("NOVUID",C0CZX) ; RECORD THE VUID 188 . D GETN1^C0CRNF("C0CD",176.001,C0CZX,"VUID","ALL") ;TRY RXNORM DB 189 . I $$ZVALUE("CODE","C0CD")=C0CZX D ; FOUND IN RXNORM 190 . . S VMATCH=VMATCH+1 ; COUNT OF PSNDF VUIDS FOUND IN RXNORM 191 . . I $$ZVALUE("NAME")=$$ZVALUE("STR","C0CD") D ;TEXT MATCHES 192 . . . S TXTMATCH=TXTMATCH+1 ; COUNT IT 193 . . E D ; TEXT DOESN'T MATCH 194 . . . S NOTM=NOTM+1 ;NO TEXT MATCH COUNTER 195 . . . S ZV=$$ZVALUE("NAME")_"^"_$$ZVALUE("STR","C0CD") 196 . . . W ZV,! 197 . . . D PUSH^GPLXPATH("TXTNM",ZV) ; RECORD THE TXT MISMATCH 198 . E S NOMATCH=NOMATCH+1 ; NOT FOUND IN RXNORM 199 . D GETN1^C0CRNF("C0CB",176.111,C0CZX,"B","ALL") ;TRY TO GET FROM 176.111 200 . I $$ZVALUE("VUID","C0CB")="" D ; VUID NOT FOUND 201 . . ;W "NOT FOUND: ",C0CZX," ",$$ZVALUE("STR")," ",$$ZVALUE("RXCUI"),! 202 . . S MISSING=MISSING+1 203 . . D PUSH^GPLXPATH("MISSING",C0CZX) ;MISSING FROM MAPPING FILE 204 . E D ; FOUND IN VA MAPPING FILE 205 . . S FOUND=FOUND+1 206 . . I $$ZVALUE("VUID TEXT","C0CB")'=$$ZVALUE("NAME") D ; TEXT DOESN'T MATCH 207 . . . S NVAM=NVAM+1 ; MAPPING FILE TEXT IS DIFFERENT THAN NDF 208 . . . S ZY=$$ZVALUE("VUID TEXT","C0CB")_"^"_$$ZVALUE("NAME") ;BOTH STRINGS 209 . . . W "VA: ",ZY,! 210 . . . D PUSH^GPLXPATH("NVAM",ZY) ;SAVE IT 211 W "MISSING IN MAPPING FILE: ",MISSING,! 212 W "FOUND IN MAPPING FILE: ",FOUND,! 213 W "FOUND IN RXNORM: ",VMATCH,! 214 W "NOT FOUND IN RXNORM: ",NOMATCH,! 215 W "ERRORS: ",NOVUID,! 216 Q 217 ; 218 . I $$ZVALUE("MEDIATION CODE")="" D 219 . . S NORXN=NORXN+1 ; 220 . E D ; PROCESS MEDIATION CODE 221 . . S HASRXN=HASRXN+1 222 . . D SETFDA("MEDIATION CODE",$$ZVALUE("MEDIATION CODE")) ; 223 . I $$ZVALUE("VUID")="" D ; BAD RECORD 224 . . S NOVUID=NOVUID+1 225 . . ;D SETFDA("VUID",$$ZVALUE("VUID")) 226 . E D SETFDA("VUID TEXT",$$ZVALUE("VUID TEXT")) 227 . . ;ZWR C0CA 228 . D GETN1^C0CRNF("C0CB",176.001,$$ZVALUE("VUID"),"VUID","ALL") 229 . I $$ZVALUE("RXCUI","C0CB")'="" D ; RXNORM FOUND 230 . . S RXFOUND=RXFOUND+1 231 . . I $$ZVALUE("MEDIATION CODE")="" D ; THIS IS A NEW CODE 232 . . . D SETFDA("MEDIATION CODE",$$ZVALUE("RXCUI","C0CB")) 233 . . . D SETFDA("NEW","Y") ;FLAG RECORD HAS HAVING NEW RXNORM 234 . . W "RXNORM=",$$ZVALUE("RXCUI","C0CB")," ",$$ZVALUE("STR","C0CB"),! 235 . . W "VUID TEXT: ",$$ZVALUE("VUID TEXT"),! 236 . . I $$ZVALUE("VUID TEXT")=$$ZVALUE("STR","C0CB") S TXTMATCH=TXTMATCH+1 237 . . E D ; 238 . . . D PUSH^GPLXPATH("NOMATCH",$$ZVALUE("VUID TEXT")_"^"_$$ZVALUE("STR","C0CB")) 239 . . . D SETFDA("RXNORM TEXT",$$ZVALUE("STR","C0CB")) ; 240 . . . D SETFDA("DIFFERENT TEXT","Y") ;FLAG RECORD FOR DIFFERENT TEXT 241 . I $$ZVALUE("MEDIATION CODE")=$$ZVALUE("RXCUI","C0CB") D ; 242 . . S RXMATCH=RXMATCH+1 243 . . W "VUID=",$$ZVALUE("VUID")," MATCH RXNORM=",$$ZVALUE("MEDIATION CODE"),! 244 . D CLEAN^DILF ; MAKE SURE WE ARE CLEANED UP 245 . S C0CFDA(176.112,"+"_C0CZX_",",.01)=$$ZVALUE("VUID") ; NEW VUID RECORD 246 . D UPDATE^DIE("","C0CFDA") 247 . I $D(^TMP("DIERR",$J)) U $P BREAK 248 W "HAS RXN=",HASRXN,! 249 W "NO RXN=",NORXN,! 250 W "NO VUID=",NOVUID,! 251 W "RXNORM FOUND=",RXFOUND,! 252 W "RXNORM MATCHES:",RXMATCH,! 253 W "TEXT MATCHES:",TXTMATCH,! 254 Q 255 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 256 ; TO SET TO VALUE C0CSV. 257 ; C0CFDA,C0CA,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 258 ; C0CSN,C0CSV ARE PASSED BY VALUE 259 ; 260 N C0CSI,C0CSJ 261 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 262 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 263 S C0CFDA(C0CSI,"+"_C0CZX_",",C0CSJ)=C0CSV 264 Q 265 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 266 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 267 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 268 I '$D(ZTAB) S ZTAB="C0CA" 269 N ZR 270 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 271 E S ZR="" 272 Q ZR 273 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 274 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 275 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 276 I '$D(ZTAB) S ZTAB="C0CA" 277 N ZR 278 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 279 E S ZR="" 280 Q ZR 281 ; 282 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 283 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 284 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 285 I '$D(ZTAB) S ZTAB="C0CA" 286 N ZR 287 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 288 E S ZR="" 289 Q ZR 290 ; -
ccr/trunk/p/C0CRXNRD.m
r597 r1336 41 41 . I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000 42 42 . N RXCUI,RXAUI,SAB,TTY,CODE,STR ; Fileman fields numbers below 43 . S RXCUI=$P(LINE,"|",1) 44 . S RXAUI=$P(LINE,"|",8) 45 . S SAB=$P(LINE,"|",12) 43 . S RXCUI=$P(LINE,"|",1) ; .01 44 . S RXAUI=$P(LINE,"|",8) ; 1 45 . S SAB=$P(LINE,"|",12) ; 2 46 46 . ; If the source is a restricted source, decide what to do based on what's asked. 47 47 . N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file … … 50 50 . ; If user didn't ask to include restricted sources, and the source is restricted, then quit 51 51 . I 'INCRES,RESTRIC QUIT 52 . S TTY=$P(LINE,"|",13) 53 . S CODE=$P(LINE,"|",14) 54 . S STR=$P(LINE,"|",15) 52 . S TTY=$P(LINE,"|",13) ; 3 53 . S CODE=$P(LINE,"|",14) ; 4 54 . S STR=$P(LINE,"|",15) ; 5 55 55 . ; Remove embedded "^" 56 56 . S STR=$TR(STR,"^") … … 88 88 . ; Otherwise, we are good to go 89 89 . N RXCUI,NDC ; Fileman fields below 90 . S RXCUI=$P(LINE,"|",1) 91 . S NDC=$P(LINE,"|",11) 90 . S RXCUI=$P(LINE,"|",1) ; .01 91 . S NDC=$P(LINE,"|",11) ; 2 92 92 . ; Using classic call to update. 93 93 . N DIC,X,DA,DR … … 117 117 . S SF=$P(LINE,"|",6) ; 6 118 118 . S SVER=$P(LINE,"|",7) ; 7 119 . S SRL=$P(LINE,"|",14) 119 . S SRL=$P(LINE,"|",14) ; 14 120 120 . S SCIT=$P(LINE,"|",25) ; 25 121 121 . ; Remove embedded "^" -
ccr/trunk/p/C0CSOAP.m
r1331 r1336 1 C0CSOAP 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 TEST1 25 26 27 28 29 INITFARY(ARY) 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 RESTID(INNAM,INFARY) 53 54 55 56 57 58 59 60 61 62 63 TESTSOAP 64 65 66 67 68 69 70 SOAP(C0CRTN,C0CTID,C0CVA,C0CVOR,ALTXML,IFARY) 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 NEW 104 105 106 107 108 109 NOTNEW 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 DEMUXARY(OARY,IARY) 174 175 176 177 178 179 180 181 182 183 184 185 NORMAL(OUTXML,INXML) 186 187 188 189 190 191 192 193 194 195 196 197 MAP(RARY,IVARS,TPTR,INFARY) 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 TESTBIND 215 216 217 218 219 220 221 222 BIND(RARY,IVARS,INTPTR,INFARY) 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 1 C0CSOAP ; CCDCCR/GPL - SOAP WEB SERVICE utilities; 8/25/09 2 ;;1.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
r1331 r1336 1 C0CSUB1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 CHK1(DFN) 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 SUBALL 46 47 48 49 50 51 52 53 SUB1(DFN,C0CSS) 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 UPDIE 69 70 71 72 73 74 75 76 77 78 79 VARPTR(ZVAR,ZTYP) 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 SETFDA(C0CSN,C0CSV) 102 103 104 105 106 107 108 109 110 111 ZFILE(ZFN,ZTAB) 112 113 114 115 116 117 118 119 ZFIELD(ZFN,ZTAB) 120 121 122 123 124 125 126 127 128 ZVALUE(ZFN,ZTAB) 129 130 131 132 133 134 135 136 1 C0CSUB1 ; CCDCCR/GPL - CCR SUBSCRIPTION utilities; 12/6/08 2 ;;1.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 CHK1(DFN) ; ADD THE CHECKSUM FOR ONE PATIENT 24 ; 25 S C0CCHK=$NA(^TMP("C0CRIM","CHKSUM")) 26 S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE 27 S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE 28 S C0CSFC=177.1012 ; FILE NUMBER FOR CHECKSUM SUBFILE 29 S C0CSFDC=177.10121 ; FILE NUMBER FOR DOMAIN CHECKSUMS 30 S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT 31 K C0CFDA 32 S C0CALL=$G(@C0CCHK@(DFN,"ALL")) 33 I C0CALL'="" S C0CFDA(C0CSFC,"?+1,"_C0CPAT_",",.01)=C0CALL 34 E Q ; NO CHECKSUMS FOR THISPATIENT 35 D UPDIE 36 N C0CJ S C0CJ="" 37 F S C0CJ=$O(@C0CCHK@(DFN,"DOMAIN",C0CJ)) Q:C0CJ="" D ; FOR EACH DOMAIN 38 . S C0CD=$O(^C0CDIC(170.101,"B",C0CJ,"")) 39 . W C0CJ," ",C0CD,! 40 . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",.01)=C0CD 41 . S C0CFDA(C0CSFDC,"?+1,1,"_C0CPAT_",",1)=@C0CCHK@(DFN,"DOMAIN",C0CJ) 42 . D UPDIE 43 Q 44 ; 45 SUBALL ; SUBSCRIBE ALL PATIENTS IN CCR GLOBALS TO SUBCRIBER 1 46 ; 47 S C0CGLB=$NA(^TMP("C0CRIM","VARS")) 48 S C0CI="" 49 F S C0CI=$O(@C0CGLB@(C0CI)) Q:C0CI="" D ; FOR EACH PATIENT 50 . D SUB1(C0CI,1) ;SUBSCIRBE THEM TO EPCRN 51 Q 52 ; 53 SUB1(DFN,C0CSS) ; SUBSCRIBE ONE PATIENT TO SUBSCRIBER C0CSS 54 ; 55 S C0CSF=177.101 ; FILE NUMBER FOR SUBSCRIPTION FILE 56 S C0CSFS=177.1011 ; FILE NUMBER FOR SUBSCRIPTION SUBFILE 57 S C0CSFC=177.10121 ; FILE NUMBER FOR CHECKSUMS 58 S C0CSSF=177.201 ; FILE NUMBER FOR SUBSCRIBER FILE 59 K C0CFDA 60 S C0CFDA(C0CSF,"+1,",.01)=DFN 61 D UPDIE ; ADD THE PATIENT 62 S C0CPAT=$O(^C0CS("B",DFN,"")) ; IEN OF PAT 63 S C0CFDA(C0CSFS,"+1,"_C0CPAT_",",.01)=C0CSS ; C0CSS IS A POINTER 64 D UPDIE ; ADD THE SUBSCRIPTION 65 D CHK1(DFN) ; ADD THE CHECKSUMS 66 Q 67 ; 68 UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS 69 K ZERR 70 D CLEAN^DILF 71 D UPDATE^DIE("","C0CFDA","","ZERR") 72 I $D(ZERR) D ; 73 . W "ERROR",! 74 . ZWR ZERR 75 . B 76 K C0CFDA 77 Q 78 ; 79 VARPTR(ZVAR,ZTYP) ;EXTRINSIC WHICH RETURNS THE POINTER TO ZVAR IN THE 80 ; CCR DICTIONARY. IT IS LAYGO, AS IT WILL ADD THE VARIABLE TO 81 ; THE CCR DICTIONARY IF IT IS NOT THERE. ZTYP IS REQUIRED FOR LAYGO 82 ; 83 N ZCCRD,ZVARN,C0CFDA2 84 S ZCCRD=170 ; FILE NUMBER FOR CCR DICTIONARY 85 S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 86 I ZVARN="" D ; VARIABLE NOT IN CCR DICTIONARY - ADD IT 87 . I '$D(ZTYP) D Q ; WON'T ADD A VARIABLE WITHOUT A TYPE 88 . . W "CANNOT ADD VARIABLE WITHOUT A TYPE: ",ZVAR,! 89 . S C0CFDA2(ZCCRD,"?+1,",.01)=ZVAR ; NAME OF NEW VARIABLE 90 . S C0CFDA2(ZCCRD,"?+1,",12)=ZTYP ; TYPE EXTERNAL OF NEW VARIABLE 91 . D CLEAN^DILF ;MAKE SURE ERRORS ARE CLEAN 92 . D UPDATE^DIE("E","C0CFDA2","","ZERR") ;ADD VAR TO CCR DICTIONARY 93 . I $D(ZERR) D ; LAYGO ERROR 94 . . W "ERROR ADDING "_ZC0CI_" TO CCR DICTIONARY",! 95 . E D ; 96 . . D CLEAN^DILF ; CLEAN UP 97 . . S ZVARN=$O(^C0CDIC(170,"B",ZVAR,"")) ;FIND IEN OF VARIABLE 98 . . W "ADDED ",ZVAR," TO CCR DICTIONARY, IEN:",ZVARN,! 99 Q ZVARN 100 ; 101 SETFDA(C0CSN,C0CSV) ; INTERNAL ROUTINE TO MAKE AN FDA ENTRY FOR FIELD C0CSN 102 ; TO SET TO VALUE C0CSV. 103 ; C0CFDA,C0CC,C0CZX ARE ASSUMED FROM THE CALLING ROUTINE 104 ; C0CSN,C0CSV ARE PASSED BY VALUE 105 ; 106 N C0CSI,C0CSJ 107 S C0CSI=$$ZFILE(C0CSN,"C0CC") ; FILE NUMBER 108 S C0CSJ=$$ZFIELD(C0CSN,"C0CC") ; FIELD NUMBER 109 S C0CFDA(C0CSI,C0CZX_",",C0CSJ)=C0CSV 110 Q 111 ZFILE(ZFN,ZTAB) ; EXTRINSIC TO RETURN FILE NUMBER FOR FIELD NAME PASSED 112 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 1 OF C0CA(ZFN) 113 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 114 I '$D(ZTAB) S ZTAB="C0CA" 115 N ZR 116 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",1) 117 E S ZR="" 118 Q ZR 119 ZFIELD(ZFN,ZTAB) ;EXTRINSIC TO RETURN FIELD NUMBER FOR FIELD NAME PASSED 120 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 2 OF C0CA(ZFN) 121 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 122 I '$D(ZTAB) S ZTAB="C0CA" 123 N ZR 124 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",2) 125 E S ZR="" 126 Q ZR 127 ; 128 ZVALUE(ZFN,ZTAB) ;EXTRINSIC TO RETURN VALUE FOR FIELD NAME PASSED 129 ; BY VALUE IN ZFN. FILE NUMBER IS PIECE 3 OF C0CA(ZFN) 130 ; IF ZTAB IS NULL, IT DEFAULTS TO C0CA 131 I '$D(ZTAB) S ZTAB="C0CA" 132 N ZR 133 I $D(@ZTAB@(ZFN)) S ZR=$P(@ZTAB@(ZFN),"^",3) 134 E S ZR="" 135 Q ZR 136 ; -
ccr/trunk/p/C0CSYS.m
r1331 r1336 1 C0CSYS 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 SYSNAME() 30 31 32 33 SYSVER() 34 35 36 PTST(DFN) 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 1 C0CSYS ;WV/C0C/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;1.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 SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic 30 Q:$G(DUZ("AG"))="I" "RPMS" 31 Q "WorldVistA EHR/VOE" 32 ; 33 SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic 34 Q "1.0" 35 ; 36 PTST(DFN) ;TEST TO SEE IF PATIENT MERGED OR A TEST PATIENT 37 ; DFN = IEN of the Patient to be tested 38 ; 1 = Merged or Test Patient 39 ; 0 = Non-test Patient 40 ; 41 I DFN="" Q 0 ; BAD DFN PASSED 42 I $D(^DPT(DFN,-9)) Q 1 ;This patient has been merged 43 I $G(^DPT(DFN,0))="" Q 1 ;Missing zeroth node <---add 44 ; 45 I '$D(CCRTEST) S CCRTEST=1 ; DEFAULT IS THAT WE ARE TESTING 46 I CCRTEST Q 0 ; IF WE ARE TESTING, DON'T REJECT TEST PATIENTS 47 N DIERR,DATA 48 I $$TESTPAT^VADPT(DFN) Q 1 ; QUIT IF IT'S A VA TEST PATIENT 49 S DATA=+$$GET1^DIQ(2,DFN_",",.6,"I") ;Test Patient Indicator 50 ; 1 = Test Patient 51 ; 0 = Non-test Patient 52 I DATA Q DATA 53 S DATA=$$GET1^DIQ(2,DFN_",",.09,"I") ;SSN test 54 D CLEAN^DILF 55 I "Pp"[$E(DATA,$L(DATA),$L(DATA)) Q 0 ;Allow Pseudo SSN 56 I $E(DATA,1,3)="000" Q 1 57 I $E(DATA,1,3)="666" Q 1 58 Q 0 59 ; -
ccr/trunk/p/C0CUNIT.m
r1331 r1336 1 C0CUNIT 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 ZT(ZARY,BAT,TST) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 ZLOAD(ZARY,ROUTINE) 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 ZTEST(ZARY,WHICH) 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 TEST 107 108 109 110 111 112 113 114 115 116 117 GTSTS(GTZARY,RTN) 118 119 120 121 122 123 124 TESTALL(RNM) 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 TLIST(ZARY) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 MEDS 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 PAT 175 176 177 178 179 180 181 182 183 184 185 186 1 C0CUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08 2 ;;1.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 ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array 25 ; ZARY IS PASSED BY REFERENCE 26 ; BAT is a string identifying the test battery 27 ; TST is a test which will evaluate to true or false 28 ; I '$G(ZARY) D 29 ; . S ZARY(0)=0 ; initially there are no elements 30 ; W "GOT HERE LOADING "_TST,! 31 N CNT ; count of array elements 32 S CNT=ZARY(0) ; contains array count 33 S CNT=CNT+1 ; increment count 34 S ZARY(CNT)=TST ; put the test in the array 35 I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY 36 . N II,TN ; TEMP FOR ENDING TEST IN BATTERY 37 . S II=$P(ZARY(BAT),"^",2) 38 . S $P(ZARY(BAT),"^",2)=II+1 39 I '$D(ZARY(BAT)) D ; FIRST TEST IN THIS BATTERY 40 . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY 41 . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX 42 . ; S TN=$NA(ZARY("TESTS")) 43 . ; D PUSH^C0CXPATH(TN,BAT) 44 S ZARY(0)=CNT ; update the array counter 45 Q 46 ; 47 ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference 48 ; ZARY IS PASSED BY NAME 49 ; ZARY = name of the root, closed array format (e.g., "^TMP($J)") 50 ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE 51 K @ZARY 52 S @ZARY@(0)=0 ; initialize array count 53 N LINE,LABEL,BODY 54 N INTEST S INTEST=0 ; switch for in the test case section 55 N SECTION S SECTION="[anonymous]" ; test case section 56 ; 57 N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE="" D 58 . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section 59 . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section 60 . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section 61 . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section 62 . I INTEST D ; within the testing section 63 . . I LINE?." "1";;><".E D ; section name found 64 . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name 65 . . I LINE?." "1";;>>".E D ; test case found 66 . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array 67 S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL 68 Q 69 ; 70 ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST 71 N ZI,ZX,ZR,ZP 72 S DEBUG=0 73 ; I WHICH="ALL" D Q ; RUN ALL THE TESTS 74 ; . W "DOING ALL",! 75 ; . N J,NT 76 ; . S NT=$NA(ZARY("TESTS")) 77 ; . W NT,@NT@(0),! 78 ; . F J=1:1:@NT@(0) D ; 79 ; . . W @NT@(J),! 80 ; . . D ZTEST^C0CUNIT(@ZARY,@NT@(J)) 81 I '$D(ZARY(WHICH)) D Q ; TEST SECTION DOESN'T EXIST 82 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! 83 N FIRST,LAST 84 S FIRST=$P(ZARY(WHICH),"^",1) 85 S LAST=$P(ZARY(WHICH),"^",2) 86 F ZI=FIRST:1:LAST D 87 . I ZARY(ZI)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT 88 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) 89 . . ; W ZP,! 90 . . S ZX=ZP 91 . . W "RUNNING: "_ZP 92 . . X ZX 93 . . W "..SUCCESS: ",WHICH,! 94 . I ZARY(ZI)?1"?"1.E D ; THIS IS A TEST 95 . . S ZP=$E(ZARY(ZI),2,$L(ZARY(ZI))) 96 . . S ZX="S ZR="_ZP 97 . . W "TRYING: "_ZP 98 . . X ZX 99 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! 100 . . I '$D(TPASSED) D ; NOT INITIALIZED YET 101 . . . S TPASSED=0 S TFAILED=0 102 . . I ZR S TPASSED=TPASSED+1 103 . . I 'ZR S TFAILED=TFAILED+1 104 Q 105 ; 106 TEST ; RUN ALL THE TEST CASES 107 N ZTMP 108 D ZLOAD(.ZTMP) 109 D ZTEST(.ZTMP,"ALL") 110 W "PASSED: ",TPASSED,! 111 W "FAILED: ",TFAILED,! 112 W ! 113 W "THE TESTS!",! 114 ; I DEBUG ZWR ZTMP 115 Q 116 ; 117 GTSTS(GTZARY,RTN) ; return an array of test names 118 N I,J S I="" S I=$O(GTZARY("TESTS",I)) 119 F J=0:0 Q:I="" D 120 . D PUSH^C0CXPATH(RTN,I) 121 . S I=$O(GTZARY("TESTS",I)) 122 Q 123 ; 124 TESTALL(RNM) ; RUN ALL THE TESTS 125 N ZI,J,TZTMP,TSTS,TOTP,TOTF 126 S TOTP=0 S TOTF=0 127 D ZLOAD^C0CUNIT("TZTMP",RNM) 128 D GTSTS(.TZTMP,"TSTS") 129 F ZI=1:1:TSTS(0) D ; 130 . S TPASSED=0 S TFAILED=0 131 . D ZTEST^C0CUNIT(.TZTMP,TSTS(ZI)) 132 . S TOTP=TOTP+TPASSED 133 . S TOTF=TOTF+TFAILED 134 . S $P(TSTS(ZI),"^",2)=TPASSED 135 . S $P(TSTS(ZI),"^",3)=TFAILED 136 F ZI=1:1:TSTS(0) D ; 137 . W "TEST=> ",$P(TSTS(ZI),"^",1) 138 . W " PASSED=>",$P(TSTS(ZI),"^",2) 139 . W " FAILED=>",$P(TSTS(ZI),"^",3),! 140 W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! 141 Q 142 ; 143 TLIST(ZARY) ; LIST ALL THE TESTS 144 ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES 145 ; ZARY IS PASSED BY REFERENCE 146 N I,J,K S I="" S I=$O(ZARY("TESTS",I)) 147 S K=1 148 F J=0:0 Q:I="" D 149 . ; W "I IS NOW=",I,! 150 . W I," " 151 . S I=$O(ZARY("TESTS",I)) 152 . S K=K+1 I K=6 D 153 . . W ! 154 . . S K=1 155 Q 156 ; 157 MEDS 158 N DEBUG S DEBUG=0 159 N DFN S DFN=5685 160 K ^TMP($J) 161 W "Loading CCR Template into T using LOAD^GPLCCR0($NA(^TMP($J,""CCR"")))",!! 162 N T S T=$NA(^TMP($J,"CCR")) D LOAD^GPLCCR0(T) 163 N XPATH S XPATH="//ContinuityOfCareRecord/Body/Medications" 164 W "XPATH is: "_XPATH,! 165 W "Getting Med Template into INXML using",! 166 W "QUERY^GPLXPATH(T,XPATH,""INXML"")",!! 167 D QUERY^GPLXPATH(T,XPATH,"INXML") 168 W "Executing EXTRACT^C0CMED(INXML,DFN,OUTXML)",! 169 W "OUTXML will be ^TMP($J,""OUT"")",! 170 N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) 171 D EXTRACT^C0CMED6("INXML",DFN,OUTXML) 172 D FILEOUT^C0CRNF(OUTXML,"TESTMEDS.xml") 173 Q 174 PAT 175 D ANALYZE^ARJTXRD("C0CDPT",.OUT) ; Analyze a routine in the directory 176 N X,Y 177 ; Select Patient 178 S DIC=2,DIC(0)="AEMQ" D ^DIC 179 ; 180 W "You have selected patient "_Y,!! 181 N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D 182 . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " 183 . W "valued at " 184 . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"C0CDPT"_"("_$P(Y,"^")_")") 185 . W ! 186 Q -
ccr/trunk/p/C0CUTIL.m
r1331 r1336 1 C0CUTIL 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 UUID() 25 26 27 28 29 30 OLDUUID() 31 32 33 34 35 36 FMDTOUTC(DATE,FORMAT) 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 SORTDT(V1,V2,ORDR) 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 DA2SNO(RTN,DNAME) 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 DASNO(DANAME) 119 120 121 122 123 124 125 126 127 DASNALL(WHICH) 128 129 130 131 132 133 134 135 136 137 RXNFN() 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 138 138 ; 139 139 CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF … … 165 165 Q ZRXN 166 166 ; 167 RPMS() 168 169 VISTA() 170 171 WV() 172 173 OV() 174 175 167 RPMS() ; Are we running on an RPMS system rather than Vista? 168 Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service 169 VISTA() ; Are we running on Vanilla Vista? 170 Q $G(DUZ("AG"))="V" ; If User Agency is VA 171 WV() ; Are we running on WorldVista? 172 Q $G(DUZ("AG"))="E" ; Code for WV. 173 OV() ; Are we running on OpenVista? 174 Q $G(DUZ("AG"))="O" ; Code for OpenVista 175 -
ccr/trunk/p/C0CVA200.m
r1331 r1336 1 C0CVA200 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 FAMILY(DUZ) 26 27 28 29 30 31 32 GIVEN(DUZ) 33 34 35 36 37 38 39 MIDDLE(DUZ) 40 41 42 43 44 45 46 SUFFIX(DUZ) 47 48 49 50 51 52 53 TITLE(DUZ) 54 55 56 57 58 59 60 61 NPI(DUZ) 62 63 64 65 66 67 68 69 70 71 72 73 SPEC(DUZ) 74 75 76 77 78 79 80 81 82 83 84 85 ADDTYPE(DUZ) 86 87 88 89 90 ADDLINE1(ADUZ) 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 CITY(ADUZ) 114 115 116 117 118 119 120 121 122 123 124 125 126 STATE(ADUZ) 127 128 129 130 131 132 133 134 135 136 137 138 POSTCODE(ADUZ) 139 140 141 142 143 144 145 146 147 148 149 150 TEL(DUZ) 151 152 153 154 155 156 157 TELTYPE(DUZ) 158 159 160 161 162 EMAIL(DUZ) 163 164 165 166 167 168 1 C0CVA200 ;WV/C0C/SMH - Routine to get Provider Data;07/13/2008 2 ;;1.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 FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC 26 ; INPUT: DUZ (i.e. File 200 IEN) ByVal 27 ; OUTPUT: String 28 N NAME S NAME=$P(^VA(200,DUZ,0),U) 29 D NAMECOMP^XLFNAME(.NAME) 30 Q NAME("FAMILY") 31 ; 32 GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC 33 ; INPUT: DUZ ByVal 34 ; OUTPUT: String 35 N NAME S NAME=$P(^VA(200,DUZ,0),U) 36 D NAMECOMP^XLFNAME(.NAME) 37 Q NAME("GIVEN") 38 ; 39 MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC 40 ; INPUT: DUZ ByVal 41 ; OUTPUT: String 42 N NAME S NAME=$P(^VA(200,DUZ,0),U) 43 D NAMECOMP^XLFNAME(.NAME) 44 Q NAME("MIDDLE") 45 ; 46 SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC 47 ; INPUT: DUZ ByVal 48 ; OUTPUT: String 49 N NAME S NAME=$P(^VA(200,DUZ,0),U) 50 D NAMECOMP^XLFNAME(.NAME) 51 Q NAME("SUFFIX") 52 ; 53 TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC 54 ; INPUT: DUZ ByVal 55 ; OUTPUT: String 56 ; Gets External Value of Title field in New Person File. 57 ; It's actually a pointer to file 3.1 58 ; 200=New Person File; 8 is Title Field 59 Q $$GET1^DIQ(200,DUZ_",",8) 60 ; 61 NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC 62 ; INPUT: DUZ ByVal 63 ; OUTPUT: Delimited String in format: 64 ; IDType^ID^IDDescription 65 ; If the NPI doesn't exist, "" is returned. 66 ; This routine uses a call documented in the Kernel dev guide 67 ; This call returns as "NPI^TimeEntered^ActiveInactive" 68 ; It returns -1 for NPI if NPI doesn't exist. 69 N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U) 70 Q:NPI=-1 "" 71 Q "NPI^"_NPI_"^HHS" 72 ; 73 SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC 74 ; INPUT: DUZ ByVal 75 ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR "" 76 ; Uses a Kernel API. Returns -1 if a specialty is not specified 77 ; in file 200. 78 ; Otherwise, returns IEN^Profession^Specialty^Subspecialty^Effect date^Expired date^VA code 79 N STR S STR=$$GET^XUA4A72(DUZ) 80 Q:+STR<0 "" 81 ; Sometimes we have 3 pieces, or 2. Deal with that. 82 Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4) 83 Q $P(STR,U,2)_"-"_$P(STR,U,3) 84 ; 85 ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC 86 ; INPUT: DUZ, but not needed really... here for future expansion 87 ; OUTPUT: At this point "Work" 88 Q "Work" 89 ; 90 ADDLINE1(ADUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC ; CHANGED PARAMETER TO ADUZ TO KEEP FROM CRASHING GPL 1/09 91 ; INPUT: DUZ ByVal 92 ; Output: String. 93 ; 94 ; First, get site number from the institution file. 95 ; 1st piece returned by $$SITE^VASITE, which gets the system institution 96 N INST S INST=$P($$SITE^VASITE(),U) 97 ; 98 ; Second, get mailing address 99 ; There are two APIs to get the address, one for physical and one for 100 ; mailing. We will check if mailing exists first, since that's the 101 ; one we want to use; then check for physical. If neither exists, 102 ; then we return nothing. We check for the existence of an address 103 ; by the length of the returned string. 104 ; NOTE: API doesn't support Address 2, so I won't even include it 105 ; in the template. 106 N ADD 107 S ADD=$$MADD^XUAF4(INST) ; mailing address 108 Q:$L(ADD) $P(ADD,U) 109 S ADD=$$PADD^XUAF4(INST) ; physical address 110 Q:$L(ADD) $P(ADD,U) 111 Q "" 112 ; 113 CITY(ADUZ) ; Get City for Institution. PUBLIC; EXTRINSIC 114 ;GPL CHANGED PARAMETER TO ADUZ TO KEEP $$SITE^VASITE FROM CRASHING 115 ; INPUT: DUZ ByVal 116 ; Output: String. 117 ; See ADD1 for comments 118 N INST S INST=$P($$SITE^VASITE(),U) 119 N ADD 120 S ADD=$$MADD^XUAF4(INST) ; mailing address 121 Q:$L(ADD) $P(ADD,U,2) 122 S ADD=$$PADD^XUAF4(INST) ; physical address 123 Q:$L(ADD) $P(ADD,U,2) 124 Q "" 125 ; 126 STATE(ADUZ) ; Get State for Institution. PUBLIC; EXTRINSIC 127 ; INPUT: DUZ ByVal 128 ; Output: String. 129 ; See ADD1 for comments 130 N INST S INST=$P($$SITE^VASITE(),U) 131 N ADD 132 S ADD=$$MADD^XUAF4(INST) ; mailing address 133 Q:$L(ADD) $P(ADD,U,3) 134 S ADD=$$PADD^XUAF4(INST) ; physical address 135 Q:$L(ADD) $P(ADD,U,3) 136 Q "" 137 ; 138 POSTCODE(ADUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC 139 ; INPUT: DUZ ByVal 140 ; OUTPUT: String. 141 ; See ADD1 for comments 142 N INST S INST=$P($$SITE^VASITE(),U) 143 N ADD 144 S ADD=$$MADD^XUAF4(INST) ; mailing address 145 Q:$L(ADD) $P(ADD,U,4) 146 S ADD=$$PADD^XUAF4(INST) ; physical address 147 Q:$L(ADD) $P(ADD,U,4) 148 Q "" 149 ; 150 TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC 151 ; INPUT: DUZ ByVal 152 ; OUTPUT: String. 153 ; Direct global access 154 N TEL S TEL=$G(^VA(200,DUZ,.13)) 155 Q $P(TEL,U,2) 156 ; 157 TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC 158 ; INPUT: DUZ ByVal 159 ; OUTPUT: String. 160 Q "Office" 161 ; 162 EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC 163 ; INPUT: DUZ ByVal 164 ; OUTPUT: String 165 ; Direct global access 166 N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) 167 Q $P(EMAIL,U) 168 ; -
ccr/trunk/p/C0CVIT2.m
r1331 r1336 1 C0CVIT2 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(VITXML,DFN,VITOUT) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 GETVISTA(DFN,C0CVIT) 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 GETRPMS(DFN,C0CVIT) 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 HEIGHT 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 WEIGHT 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 BP 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 TMP 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 RESP 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 PULSE 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 PAIN 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 OTHER 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 HEIGHT1(DT,ACTOR,VALUE,UNIT) 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 WEIGHT1(DT,ACTOR,VALUE,UNIT) 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 BP1(DT,ACTOR,VALUE,UNIT) 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 TMP1(DT,ACTOR,VALUE,UNIT) 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 RESP1(DT,ACTOR,VALUE,UNIT) 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 PULSE1(DT,ACTOR,VALUE,UNIT) 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 PAIN1(DT,ACTOR,VALUE,UNIT) 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 OTHER1(DT,TEXT,ACTOR,VALUE,UNIT) 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 VITSORT(VDT) 444 445 446 447 448 449 450 451 452 453 454 455 456 MAP(VITXML,C0CVIT,VITOUT) 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 1 C0CVIT2 ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/08 2 ;;1.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/C0CVITAL.m
r1331 r1336 1 C0CVITAL 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 EXTRACT(VITXML,DFN,VITOUTXML) 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 VITVISTA 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 1 C0CVITAL ; CCDCCR/CJE/GPL - CCR/CCD PROCESSING FOR VITALS ; 07/16/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(VITXML,DFN,VITOUTXML) ; EXTRACT VITALS INTO PROVIDED XML TEMPLATE 25 ; 26 ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED 27 ; IVITXML CONTAINS ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE 28 ; 29 N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF,VORDR 30 S C0CVLMT=$$GET^C0CPARMS("VITLIMIT") ; GET THE LIMIT PARM 31 S C0CVSTRT=$$GET^C0CPARMS("VITSTART") ; GET START PARM 32 D DT^DILF(,C0CVLMT,.C0CEDT) ; 33 D DT^DILF(,C0CVSTRT,.C0CSDT) ; 34 ;D DT^DILF(,C0CVLMT,.C0CSDT) ; GPL TESTING 35 ;D DT^DILF(,C0CVSTRT,.C0CEDT) ; 36 W "VITALS START: ",C0CVSTRT," LIMIT: ",C0CVLMT,! 37 I $$RPMS^C0CUTIL() D VITRPMS QUIT 38 I ($$VISTA^C0CUTIL())!($$WV^C0CUTIL())!($$OV^C0CUTIL()) D VITVISTA QUIT 39 ;I $$SYSNAME^C0CSYS()="RPMS" D VITRPMS 40 ;E D VITVISTA 41 Q 42 ; 43 VITVISTA ; EXTRACT VITALS FROM VISTA INTO PROVIDED XML TEMPLATE 44 D FASTVIT^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) ; GPL THIS ONE WORKS FOR AT 45 ; LEAST ONE SET OF VITALS - TO DO, CALL IT REPETIVELY TO GET EARLIER VITALS 46 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CEDT,C0CSDT) 47 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CSDT,C0CEDT) 48 ;D VITALS^ORQQVI(.VITRSLT,DFN,C0CVSTRT,C0CVLMT) ; GPL LET GMR HANDLE THE DATES 49 I '$D(VITRSLT(1)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT 50 I $P(VITRSLT(1),U,2)="No vitals found." D Q ; NULL RESULT FROM RPC 51 . I DEBUG W "NO VITALS FOUND FROM VITALS RPC",! 52 . S @VITOUTXML@(0)=0 53 I $P(VITRSLT(1),U,2)="No vitals found." Q ; QUIT 54 ; ZWR RPCRSLT 55 S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) 56 S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) 57 K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES 58 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 59 D VITDVISTA(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 60 I DEBUG ZWR VDATES ;DEBUG 61 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 62 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY 63 S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS 64 F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST 65 . I $D(VITRSLT(VSORT(J))) D 66 . . S VITVMAP=$NA(@VITTVMAP@(J)) 67 . . K @VITVMAP 68 . . I DEBUG W "VMAP= ",VITVMAP,! 69 . . S VITPTMP=VITRSLT(VSORT(J)) ; DATE SORTED VITAL FROM RETURN ARRAY 70 . . I DEBUG W "VITAL ",VSORT(J),! 71 . . I DEBUG W VITRSLT(VSORT(J))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! 72 . . I DEBUG W $P(VITPTMP,U,4),! 73 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 74 74 . . ;B ;gpl 75 75 . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) 76 76 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; 77 77 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" 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 78 . . I $P(VITPTMP,U,2)="HT" D 79 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 80 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 81 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 82 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 83 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 84 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 85 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 86 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" 87 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 88 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 89 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 90 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 91 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in" 92 . . E I $P(VITPTMP,U,2)="WT" D 93 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 94 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 95 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 96 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 97 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 98 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 99 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 100 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" 101 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 102 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 103 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 104 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 105 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs" 106 . . E I $P(VITPTMP,U,2)="BP" D 107 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 108 . . . ;S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 109 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 110 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 111 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 112 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 113 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 114 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" 115 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 116 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 117 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 118 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 119 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 120 . . E I $P(VITPTMP,U,2)="T" D 121 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 122 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 123 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 124 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 125 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 126 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 127 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 128 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" 129 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 130 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 131 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 132 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 133 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="F" 134 . . E I $P(VITPTMP,U,2)="R" D 135 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 136 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 137 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 138 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 139 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 140 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 141 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 142 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" 143 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 144 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 145 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 146 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 147 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 148 . . E I $P(VITPTMP,U,2)="P" D 149 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 150 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 151 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 152 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 153 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 154 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 155 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 156 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" 157 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 158 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 159 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 160 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 161 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 162 . . E I $P(VITPTMP,U,2)="PN" D 163 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 164 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 165 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 166 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 167 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 168 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 169 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 170 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" 171 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 172 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 173 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 174 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 175 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 176 . . E I $P(VITPTMP,U,2)="BMI" D 177 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 178 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 179 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" 180 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 181 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 182 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 183 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BMI" 184 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="60621009" 185 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 186 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 187 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P(^GMR(120.5,$P(VITPTMP,U,1),0),U,6) 188 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 189 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="" 190 . . E D 191 . . . ;W "IN VITAL: OTHER",! 192 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 193 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 194 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL" 195 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 196 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 197 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="UNKNOWN" 198 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER" 199 . . . ;S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" 200 . . . ;S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" 201 . . . ;S @VITVMAP@("VITALSIGNSCODEVERSION")="" 202 . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^GMR(120.5,$P(VITPTMP,U,1),0)),U,6) 203 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3) 204 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN" 205 205 . . I @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_" D ; 206 206 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORSYSTEM_1" ; 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 VITRPMS 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 VITDRPMS(VDT) 389 390 391 392 393 394 395 396 397 398 399 400 401 VITDVISTA(VDT) 402 403 404 405 406 407 408 409 410 411 412 413 207 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 208 . . K @VITARYTMP 209 . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) 210 . . I J=1 D ; FIRST ONE IS JUST A COPY 211 . . . ; W "FIRST ONE",! 212 . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) 213 . . . I DEBUG W "VITOUTXML ",VITOUTXML,! 214 . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 215 . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) 216 ; ZWR ^TMP($J,"VITALS",*) 217 ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS 218 I DEBUG D PARY^C0CXPATH(VITOUTXML) 219 N VITTMP,I 220 D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS 221 I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 222 . W "VITALS MISSING ",! 223 . F I=1:1:VITTMP(0) W VITTMP(I),! 224 Q 225 ; 226 VITRPMS ; EXTRACT VITALS FROM RPMS INTO PROVIDED XML TEMPLATE 227 ; RPMS VITAL RPC ONLY RETURNS LATEST VITAL IN SPECIFIED DATE RANGE NOT ALL VITALS IN DATE RANGE 228 ; WE NEED TO SETUP THE VARIABLES THE INTERNAL CALL NEEDS TO BYPASS A HARD CODE OF ONE VITAL FOR DATE RANGE 229 N END,START,DATA 230 D DT^DILF("",C0CVLMT,.END) 231 D DT^DILF("",C0CVSTRT,.START) 232 ; RPC OUTPUT FORMAT: 233 ; vfile ien^vital name^vital abbr^date/time taken(FM FORMAT)^value+units (US & metric) 234 D QUERY^BEHOVM("LISTX") ; RUN QUERY VITALS CALL 235 I '$D(^TMP("CIAVMRPC",$J)) S @VITOUTXML@(0)=0 Q ; RETURN NOT FOUND AND QUIT 236 ;ZW ^TMP("CIAVMRPC",$J) 237 S VITTVMAP=$NA(^TMP("C0CCCR",$J,"VITALS")) 238 S VITTARYTMP=$NA(^TMP("C0CCCR",$J,"VITALARYTMP")) 239 K @VITTVMAP,@VITTARYTMP ; KILL OLD ARRAY VALUES 240 N VSORT,VDATES,VCNT ; ARRAY FOR DATE SORTED VITALS INDEX 241 D VITDRPMS(.VDATES) ; PULL OUT THE DATES INTO AN ARRAY 242 S VCNT=$$SORTDT^C0CUTIL(.VSORT,.VDATES,-1) ; PUT VITALS IN REVERSE 243 ; DATE ORDER AND COUNT THEM. VSORT CONTAINS INDIRECT INDEXES ONLY 244 S @VITTVMAP@(0)=VCNT ; SAVE NUMBER OF VITALS 245 F J=1:1:VCNT D ; FOR EACH VITAL IN THE LIST 246 . I $D(^TMP("CIAVMRPC",$J,0,(VSORT(J)))) D 247 . . S VITVMAP=$NA(@VITTVMAP@(J)) 248 . . K @VITVMAP 249 . . I DEBUG W "VMAP= ",VITVMAP,! 250 . . S VITPTMP=^TMP("CIAVMRPC",$J,0,(VSORT(J))) ; DATE SORTED VITAL FROM RETURN ARRAY 251 . . I DEBUG W "VITAL ",VSORT(J),! 252 . . I DEBUG W ^TMP("CIAVMRPC",$J,0,(VSORT(J)))," ",$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT"),! 253 . . I DEBUG W $P(VITPTMP,U,4),! 254 . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID 255 . . I $P(VITPTMP,U,3)="HT" D 256 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 257 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 258 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 259 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 260 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 261 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 262 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT" 263 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="248327008" 264 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 265 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 266 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 267 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 268 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 269 . . E I $P(VITPTMP,U,3)="WT" D 270 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 271 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 272 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 273 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 274 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 275 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 276 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT" 277 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="107647005" 278 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 279 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 280 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 281 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 282 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 283 . . E I $P(VITPTMP,U,3)="BP" D 284 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 285 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 286 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 287 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 288 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 289 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 290 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="BLOOD PRESSURE" 291 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="392570002" 292 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 293 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 294 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 295 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 296 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 297 . . E I $P(VITPTMP,U,3)="TMP" D 298 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 299 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 300 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 301 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 302 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 303 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 304 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="TEMPERATURE" 305 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="309646008" 306 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 307 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 308 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 309 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 310 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 311 . . E I $P(VITPTMP,U,3)="RS" D 312 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 313 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 314 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 315 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 316 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 317 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 318 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="RESPIRATION" 319 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366147009" 320 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 321 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 322 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 323 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 324 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 325 . . E I $P(VITPTMP,U,3)="PU" D 326 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 327 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 328 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 329 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 330 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 331 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 332 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PULSE" 333 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="366199006" 334 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 335 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 336 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 337 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 338 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 339 . . E I $P(VITPTMP,U,3)="PA" D 340 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 341 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 342 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 343 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 344 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 345 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 346 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="PAIN" 347 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="22253000" 348 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="SNOMED" 349 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 350 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 351 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 352 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 353 . . E D 354 . . . ;W "IN VITAL: OTHER",! 355 . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED" 356 . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^C0CUTIL($P(VITPTMP,U,4),"DT") 357 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) 358 . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")="ACTORSYSTEM_1" 359 . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J 360 . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED" 361 . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")=$P(VITPTMP,U,2) 362 . . . S @VITVMAP@("VITALSIGNSDESCCODEVALUE")="" 363 . . . S @VITVMAP@("VITALSIGNSDESCCODINGSYSTEM")="" 364 . . . S @VITVMAP@("VITALSIGNSCODEVERSION")="" 365 . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")="ACTORPROVIDER_"_$P($G(^AUPNVMSR($P(VITPTMP,U,1),12)),U,4) 366 . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P($P(VITPTMP,U,5)," ",1) 367 . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")=$P($P(VITPTMP,U,5)," ",2) 368 . . S VITARYTMP=$NA(@VITTARYTMP@(J)) 369 . . K @VITARYTMP 370 . . D MAP^C0CXPATH(VITXML,VITVMAP,VITARYTMP) 371 . . I J=1 D ; FIRST ONE IS JUST A COPY 372 . . . ; W "FIRST ONE",! 373 . . . D CP^C0CXPATH(VITARYTMP,VITOUTXML) 374 . . . I DEBUG W "VITOUTXML ",VITOUTXML,! 375 . . I J>1 D ; AFTER THE FIRST, INSERT INNER XML 376 . . . D INSINNER^C0CXPATH(VITOUTXML,VITARYTMP) 377 ; ZWR ^TMP($J,"VITALS",*) 378 ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS 379 I DEBUG D PARY^C0CXPATH(VITOUTXML) 380 N VITTMP,I 381 D MISSING^C0CXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS 382 I VITTMP(0)>0 D ; IF THERE ARE MISSING VARS - MARKED AS @@X@@ 383 . W "VITALS MISSING ",! 384 . F I=1:1:VITTMP(0) W VITTMP(I),! 385 K ^TMP("CIAVMRPC",$J) 386 Q 387 ; 388 VITDRPMS(VDT) ; RUN DATE SORTING ALGORITHM FOR RPMS 389 ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY 390 ; OF DATES IN THE VITALS RESULTS 391 N VDTI,VDTJ,VTDCNT 392 S VTDCNT=0 ; COUNT TO BUILD ARRAY 393 S VDTJ="" ; USED TO VISIT THE RESULTS 394 F VDTI=0:0 D Q:$O(^TMP("CIAVMRPC",$J,0,VDTJ))="" ; VISIT ALL RESULTS 395 . S VDTJ=$O(^TMP("CIAVMRPC",$J,0,VDTJ)) ; NEXT RESULT 396 . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER 397 . S VDT(VTDCNT)=$P(^TMP("CIAVMRPC",$J,0,VDTJ),U,4) ; PULL OUT THE DATE 398 S VDT(0)=VTDCNT 399 Q 400 ; 401 VITDVISTA(VDT) ; RUN DATE SORTING ALGORITHM FOR VISTA 402 ; VDT IS PASSED BY REFERENCE AND WILL CONTAIN THE ARRAY 403 ; OF DATES IN THE VITALS RESULTS 404 N VDTI,VDTJ,VTDCNT 405 S VTDCNT=0 ; COUNT TO BUILD ARRAY 406 S VDTJ="" ; USED TO VISIT THE RESULTS 407 F VDTI=0:0 D Q:$O(VITRSLT(VDTJ))="" ; VISIT ALL RESULTS 408 . S VDTJ=$O(VITRSLT(VDTJ)) ; NEXT RESULT 409 . S VTDCNT=VTDCNT+1 ; INCREMENT COUNTER 410 . S VDT(VTDCNT)=$P(VITRSLT(VDTJ),U,4) ; PULL OUT THE DATE 411 S VDT(0)=VTDCNT 412 Q 413 ; -
ccr/trunk/p/C0CVOBX1.m
r508 r1336 19 19 I LA7X]"","BO"'[LA7X Q 20 20 I LA7X="",'$$OKTOSND^LA7VHLU1(LRSS,LRSB,+$P($P(LA7VAL,"^",3),"!",5)) Q 21 22 23 24 25 26 27 28 21 ; 22 ; If no result NLT or LOINC try to determine from file #60 23 S LA7X=$P(LA7VAL,"^",3) 24 ; WV check for IHS - NLT/LN codes from V LAB file 25 I $D(^AUPNVLAB) D TMPCHK^C0CLA7Q 26 ; 27 I $P(LA7X,"!",2)=""!($P(LA7X,"!",3)="") S $P(LA7VAL,"^",3)=$$DEFCODE^LA7VHLU5(LRSS,LRSB,LA7X,$P(LA76304(0),"^",5)) 28 ; No result NLT code - log error 29 29 I $P($P(LA7VAL,"^",3),"!",2)="" D 30 30 . N LA7X -
ccr/trunk/p/C0CXPAT0.m
r1331 r1336 1 C0CXPAT0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 1 C0CXPAT0 ; CCDCCR/GPL - XPATH TEST CASES ; 6/1/08 2 ;;1.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
r1331 r1336 1 C0CXPATH 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 OUTPUT(OUTARY,OUTNAME,OUTDIR) 25 26 27 28 29 30 31 32 PUSH(STK,VAL) 33 34 35 36 37 38 39 40 POP(STK,VAL) 41 42 43 44 45 46 47 48 49 50 51 52 PUSHA(ADEST,ASRC) 53 54 55 56 57 58 59 MKMDX(STK,RTN,INREDUX) 60 61 62 63 64 65 66 67 68 69 70 71 72 XNAME(ISTR) 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 XVAL(ISTR) 88 89 90 91 92 93 VDX2VDV(OUTVDV,INVDX) 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 VDX2XPG(OUTXPG,INVDX) 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 XML2XPG(OUTXPG,INXML) 130 131 132 133 134 135 136 137 DO 138 139 140 141 T1 142 143 144 145 146 147 148 149 XPG2XML(OUTXML,INXPG) 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 ZXO(WHAT) 191 192 193 194 195 ZXC(WHAT) 196 197 198 199 200 ZXVAL(WHAT,VAL) 201 202 203 204 INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 MKLASD(OUTBUF,INARY) 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 CLEAN(STR,TR) 327 328 329 330 331 332 333 334 335 336 QUERY(IARY,XPATH,OARY) 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 XF(IDX,XPATH) 361 362 363 364 365 XL(IDX,XPATH) 366 367 368 369 370 START(ISTR) 371 372 373 374 375 FINISH(ISTR) 376 377 378 379 ARRAY(ISTR) 380 381 382 383 BUILD(BLIST,BDEST) 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 QUEUE(BLST,ARRAY,FIRST,LAST) 402 403 404 405 406 407 CP(CPSRC,CPDEST) 408 409 410 411 412 413 414 415 416 417 418 419 QOPEN(QOBLIST,QOXML,QOXPATH) 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 QCLOSE(QCBLIST,QCXML,QCXPATH) 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 INSERT(INSXML,INSNEW,INSXPATH) 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 INSINNER(INNXML,INNNEW,INNXPATH) 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 INSB4(XDEST,XNEW) 507 508 509 510 511 512 513 514 515 516 517 REPLACE(REXML,RENEW,REXPATH) 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 DELETE(REXML,REXPATH) 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 MISSING(IXML,OARY) 558 559 560 561 562 563 564 565 566 567 568 569 MAP(IXML,INARY,OXML) 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 DOFLD 600 601 602 603 TRIM(THEXML) 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 UNMARK(XSEC) 642 643 644 645 646 647 648 649 PARY(GLO,ZN) 650 651 652 653 654 655 656 657 H2ARY(IARYRTN,IHASH,IPRE) 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 XVARS(XVRTN,XVIXML) 684 685 686 687 688 689 690 691 692 693 694 DXVARS(DXIN) 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 TEST 711 712 713 714 ZTEST(WHICH) 715 716 717 718 719 720 721 TLIST 722 723 724 725 726 1 C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 2 ;;1.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 OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE 25 ; 26 N Y 27 S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) 28 I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR 29 I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR 30 Q 31 ; 32 PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) 33 ; VAL IS A STRING AND STK IS PASSED BY NAME 34 ; 35 I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE 36 S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH 37 S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY 38 Q 39 ; 40 POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL 41 ; VAL AND STK ARE PASSED BY REFERENCE 42 ; 43 I @STK@(0)<1 D ; IF ARRAY IS EMPTY 44 . S VAL="" 45 . S @STK@(0)=0 46 I @STK@(0)>0 D ; 47 . S VAL=@STK@(@STK@(0)) 48 . K @STK@(@STK@(0)) 49 . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY 50 Q 51 ; 52 PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME 53 ; 54 N ZGI 55 F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY 56 . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT 57 Q 58 ; 59 MKMDX(STK,RTN,INREDUX) ; MAKES A MUMPS INDEX FROM THE ARRAY STK 60 ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS 61 ; REDUX IS A STRING TO REMOVE FROM THE RESULT 62 S RTN="" 63 N I 64 ; W "STK= ",STK,! 65 I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY 66 . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON 67 . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON 68 . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) 69 I $G(INREDUX)'="" S RTN=$P(RTN,INREDUX,1)_$P(RTN,INREDUX,2) 70 Q 71 ; 72 XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG 73 ; </NAME> AND <NAME ID=XNAME> WILL RETURN NAME 74 ; ISTR IS PASSED BY VALUE 75 N CUR,TMP 76 I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET 77 . S TMP=$P(ISTR,"<",2) 78 I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME> 79 . S TMP=$P(TMP,"/",2) 80 S CUR=$P(TMP,">",1) ; EXTRACT THE NAME 81 ; W "CUR= ",CUR,! 82 I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> 83 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER 84 ; W "CUR2= ",CUR,! 85 Q CUR 86 ; 87 XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML 88 ; <NAME>VALUE</NAME> WILL RETURN VALUE 89 N G 90 S G=$P(ISTR,">",2) ;STRIP OFF <NAME> 91 Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE 92 ; 93 VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV 94 ; VDX: @INVDX@(XPATH)=VALUE 95 ; VDV: @OUTVDV@(X1X2X3X4)=VALUE 96 ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE 97 ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS 98 ; @VDV@("XPATH",X1X2X3X4)="XPATH" 99 N ZA,ZI,ZW 100 S ZI="" 101 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; 102 . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME 103 . W ZW,! 104 . S @OUTVDV@(ZW)=@INVDX@(ZI) 105 . S @OUTVDV@("XPATH",ZW)=ZI 106 Q 107 ; 108 VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG 109 ; VDX: @VDX@(XPATH)=VALUE 110 ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE 111 ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX 112 N ZA,ZI,ZW 113 S ZI="" 114 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ; 115 . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL // 116 . S ZW2=$P(ZW,"/",1) 117 . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK)) 118 . ;ZWR ZA 119 . S ZW2=ZA(1) 120 . F ZK=2:1:ZA(0) D ; 121 . . S ZW2=ZW2_""","""_ZA(ZK) 122 . K ZA 123 . S ZW2=""""_ZW2_"""" 124 . W ZW2,! 125 . S ZN=OUTXPG_"("_ZW2_")" 126 . S @ZN=@INVDX@(ZI) 127 Q 128 ; 129 XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY 130 ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE 131 ; 132 ;N G1 133 D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED 134 D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM 135 Q 136 ; 137 DO 138 D XPG2XML("^GPL2B","^GPL2A") 139 Q 140 ; 141 T1 ; TEST OUT THESE ROUTINES 142 D XML2XPG("G2","^GPL") 143 D XPG2XML("G3","G2") 144 K ^GPLOUT 145 M ^GPLOUT=G3 146 W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p") 147 Q 148 ; 149 XPG2XML(OUTXML,INXPG) ; 150 N C0CN,FWD,ZA,G,GA,ZQ 151 S ZQ=0 ; QUIT FLAG 152 F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING 153 . I '$D(C0CN) D ; FIRST TIME THROUGH 154 . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR 155 . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS 156 . . S G=$Q(@INXPG) ; THIS ONE 157 . . S GN=$Q(@G) ; NEXT ONE 158 . . S C0CN=1 ; SUBSCRIPT COUNT 159 . . S ZQ=0 ; QUIT FLAG 160 . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML 161 . . I $QS(G,1)="ContinuityOfCareRecord" D ; 162 . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK 163 . I FWD D ; GOING FORWARDS 164 . . I C0CN<$QL(G) D ; NOT A DATA NODE 165 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT 166 . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT 167 . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D ; 168 . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">" 169 . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE 170 . . E D ; AT THE DATA NODE 171 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT 172 . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE 173 . . . S FWD=0 ; GO BACKWARDS 174 . I 'FWD D ;GOING BACKWARDS 175 . . S GN=$Q(@G) ;NEXT XPATH 176 . . ;W "NEXT!",GN,! 177 . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT 178 . . I GN'="" D ; 179 . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT 180 . . . . D ZXC($QS(G,C0CN)) ; 181 . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL 182 . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH 183 . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT 184 . . . . S FWD=1 ; GOING FORWARD NOW 185 . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE 186 . . D ZXC($QS(G,C0CN)) ; LAST ONE 187 . . S ZQ=1 ; QUIT NOW 188 Q 189 ; 190 ZXO(WHAT) 191 D PUSH("GA",WHAT) 192 D PUSH(OUTXML,"<"_WHAT_">") 193 Q 194 ; 195 ZXC(WHAT) 196 D POP("GA",.TMP) 197 D PUSH(OUTXML,"</"_WHAT_">") 198 Q 199 ; 200 ZXVAL(WHAT,VAL) 201 D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">") 202 Q 203 ; 204 INDEX(IZXML,VDX,NOINX,TEMPLATE,REDUX) ; parse XML in IZXML and produce 205 ; an XPATH index; REDUX is a string to be removed from each xpath 206 ; GPL 7/14/09 OPTIONALLY GENERATE AN XML TEMPLATE IF PASSED BY NAME 207 ; TEMPLATE IS IDENTICAL TO THE PARSED XML LINE BY LINE 208 ; EXCEPT THAT DATA VALUES ARE REPLACED WITH @@XPATH@@ FOR THE XPATH OF THE TAG 209 ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME 210 ; @VDX@("XPATH")=VALUE 211 ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE 212 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE 213 ; XML SECTION 214 ; IZXML IS PASSED BY NAME 215 ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE 216 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT 217 N C0CSTK ; LEAVE OUT FOR DEBUGGING 218 I '$D(REDUX) S REDUX="" 219 I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX 220 N ZXML 221 I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD 222 E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP 223 I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM 224 . S I="",LCNT=0 225 . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1 226 E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY 227 I LCNT=0 D Q ; NO XML PASSED 228 . W "ERROR IN XML FILE",! 229 S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX 230 I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX 231 S C0CSTK(0)=0 ; INITIALIZE STACK 232 K LKASD ; KILL LOOKASIDE ARRAY 233 D MKLASD(.LKASD,IZXML) ;MAKE LOOK ASIDE BUFFER FOR MULTIPLES 234 F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY 235 . S LINE=@IZXML@(I) 236 . I $D(TEMPLATE) D ;IF TEMPLATE IS REQUESTED 237 . . S @TEMPLATE@(I)=$$CLEAN(LINE) 238 . ;W LINE,! 239 . S FOUND=0 ; INTIALIZED FOUND FLAG 240 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS 241 . I FOUND'=1 D 242 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E) D 243 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS 244 . . . ; ON THE SAME LINE 245 . . . ; W "FOUND ",LINE,! 246 . . . S FOUND=1 ; SET FOUND FLAG 247 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 248 . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES 249 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK 250 . . . D MKMDX("C0CSTK",.MDX,REDUX) ; GENERATE THE M INDEX 251 . . . ; W "MDX=",MDX,! 252 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 253 . . . . ;I '$D(ZDUP(MDX)) S ZDUP(MDX)=2 254 . . . . ;E S ZDUP(MDX)=ZDUP(MDX)+1 255 . . . . ;W "DUP:",MDX,! 256 . . . . ;I '$D(CURVAL) S CURVAL="" 257 . . . . ;I DVDX S @VDX@(MDX_"["_ZDUP(MDX)_"]")=CURVAL 258 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 259 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 260 . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST 261 . . . . S CURVAL=$$XVAL(LINE) ; VALUE 262 . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE 263 . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED 264 . . . . I $D(TEMPLATE) D ; IF TEMPLATE IS REQUESTED 265 . . . . . S LINE=$$CLEAN(LINE) ; CLEAN OUT CONTROL CHARACTERS 266 . . . . . S @TEMPLATE@(I)=$P(LINE,">",1)_">@@"_MDX_"@@</"_$P(LINE,"</",2) 267 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK 268 . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END 269 . . I LINE?.E1"</"1.E D ; LINE CONTAINS END OF A SECTION 270 . . . ; W "FOUND ",LINE,! 271 . . . S FOUND=1 ; SET FOUND FLAG 272 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 273 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX 274 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 275 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK 276 . . . S TMP=$P(TMP,"[",1) ; REMOVE [X] FROM MULTIPLE 277 . . . I TMP'=CUR D ; MALFORMED XML, END MUST MATCH START 278 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,! 279 . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING 280 . . . . Q 281 . I FOUND'=1 D ; THE LINE MIGHT CONTAIN A SECTION BEGINNING 282 . . I (LINE?.E1"<"1.E)&(LINE'["?>") D ; BEGINNING OF A SECTION 283 . . . ; W "FOUND ",LINE,! 284 . . . S FOUND=1 ; SET FOUND FLAG 285 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 286 . . . S CUR=CUR_$G(LKASD(CUR,I)) ; HANDLE MULTIPLES 287 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK 288 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX 289 . . . ; W "MDX=",MDX,! 290 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 291 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 292 . . . . ;B 293 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 294 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX 295 S @ZXML@("INDEXED")="" 296 S @ZXML@("//")="1^"_LCNT ; ROOT XPATH 297 I NOINX K @ZXML ; DELETE UNWANTED INDEX 298 Q 299 ; 300 MKLASD(OUTBUF,INARY) ; CREATE A LOOKASIDE BUFFER FOR MULTILPLES 301 ; 302 N ZI,ZN,ZA,ZLINE,ZLINE2,CUR,CUR2 303 F ZI=1:1:LCNT-1 D ; PROCESS THE ENTIRE ARRAY 304 . S ZLINE=@IZXML@(ZI) 305 . I ZI<LCNT S ZLINE2=@IZXML@(ZI+1) 306 . I ZLINE?.E1"</"1.E D ; NEXT LINE CONTAINS END OF A SECTION 307 . . S CUR=$$XNAME(ZLINE) ; EXTRACT THE NAME 308 . . I (ZLINE2?.E1"<"1.E)&(ZLINE'["?>") D ; BEGINNING OF A SECTION 309 . . . S CUR2=$$XNAME(ZLINE2) ; EXTRACT THE NAME 310 . . . I CUR=CUR2 D ; IF THIS IS A MULTIPLE 311 . . . . S OUTBUF(CUR,ZI+1)="" 312 ;ZWR OUTBUF 313 S ZI="" 314 F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; FOR EACH KIND OF MULTIPLE 315 . S ZN=$O(OUTBUF(ZI,"")) ; LINE NUMBER OF SECOND MULTIPLE 316 . F S ZN=$O(@IZXML@(ZN),-1) Q:ZN="" I $E($P(@IZXML@(ZN),"<"_ZI,2),1,1)=">" Q ; 317 . S OUTBUF(ZI,ZN)="" 318 S ZA=1,ZI="",ZN="" 319 F S ZI=$O(OUTBUF(ZI)) Q:ZI="" D ; ADDING THE COUNT FOR THE MULIPLES [x] 320 . S ZN="",ZA=1 321 . F S ZN=$O(OUTBUF(ZI,ZN)) Q:ZN="" D ; 322 . . S OUTBUF(ZI,ZN)="["_ZA_"]" 323 . . S ZA=ZA+1 324 Q 325 ; 326 CLEAN(STR,TR) ; extrinsic function; returns string 327 ;; Removes all non printable characters from a string. 328 ;; STR by Value 329 ;; TR IS OPTIONAL TO IMPROVE PERFORMANCE 330 N TR,I 331 I '$D(TR) D ; 332 . F I=0:1:31 S TR=$G(TR)_$C(I) 333 . S TR=TR_$C(127) 334 QUIT $TR(STR,TR) 335 ; 336 QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION 337 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" 338 ; IARY AND OARY ARE PASSED BY NAME 339 I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY 340 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML 341 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN 342 N TMP,I,J,QXPATH 343 S FIRST=1 344 I '$D(@IARY@(0)) D ; LINE COUNT NOT IN ZERO NODE 345 . S @IARY@(0)=$O(@IARY@("//"),-1) ; THIS SHOULD USUALLY WORK 346 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT 347 I XPATH'="//" D ; NOT A ROOT QUERY 348 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES 349 . S FIRST=$P(TMP,"^",1) 350 . S LAST=$P(TMP,"^",2) 351 K @OARY 352 S @OARY@(0)=+LAST-FIRST+1 353 S J=1 354 FOR I=FIRST:1:LAST D 355 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY 356 . S J=J+1 357 ; ZWR OARY 358 Q 359 ; 360 XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH 361 ; INDEX WITH TWO PIECES START^FINISH 362 ; IDX IS PASSED BY NAME 363 Q $P(@IDX@(XPATH),"^",1) 364 ; 365 XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH 366 ; INDEX WITH TWO PIECES START^FINISH 367 ; IDX IS PASSED BY NAME 368 Q $P(@IDX@(XPATH),"^",2) 369 ; 370 START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX 371 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 372 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME 373 Q $P(ISTR,";",2) 374 ; 375 FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX 376 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 377 Q $P(ISTR,";",3) 378 ; 379 ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX 380 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 381 Q $P(ISTR,";",1) 382 ; 383 BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST 384 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST 385 ; DEST IS CLEARED TO START 386 ; USES PUSH TO DO THE COPY 387 N I 388 K @BDEST 389 F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST 390 . N J,ATMP 391 . S ATMP=$$ARRAY(@BLIST@(I)) 392 . I $G(DEBUG) W "ATMP=",ATMP,! 393 . I $G(DEBUG) W @BLIST@(I),! 394 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; 395 . . ; FOR EACH LINE IN THIS INSTR 396 . . I $G(DEBUG) W "BDEST= ",BDEST,! 397 . . I $G(DEBUG) W "ATMP= ",@ATMP@(J),! 398 . . D PUSH(BDEST,@ATMP@(J)) 399 Q 400 ; 401 QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST 402 ; 403 I $G(DEBUG) W "QUEUEING ",BLST,! 404 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) 405 Q 406 ; 407 CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME 408 ; KILLS CPDEST FIRST 409 N CPINSTR 410 I $G(DEBUG) W "MADE IT TO COPY",CPSRC,CPDEST,! 411 I @CPSRC@(0)<1 D ; BAD LENGTH 412 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! 413 . Q 414 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT 415 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY 416 D BUILD("CPINSTR",CPDEST) 417 Q 418 ; 419 QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST 420 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD 421 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT 422 ; USED TO INSERT CHILDREN NODES 423 I @QOXML@(0)<1 D ; MALFORMED XML 424 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! 425 . Q 426 I $G(DEBUG) W "DOING QOPEN",! 427 N S1,E1,QOT,QOTMP 428 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML 429 I $D(QOXPATH) D ; XPATH PROVIDED 430 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX 431 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 432 I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 433 . S E1=@QOXML@(0)-1 434 D QUEUE(QOBLIST,QOXML,S1,E1) 435 ; S QOTMP=QOXML_"^"_S1_"^"_E1 436 ; D PUSH(QOBLIST,QOTMP) 437 Q 438 ; 439 QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN 440 ; ADDS THE LIST LINE OF QCXML TO QCBLIST 441 ; USED TO FINISH INSERTING CHILDERN NODES 442 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END 443 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO 444 I @QCXML@(0)<1 D ; MALFORMED XML 445 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! 446 I $G(DEBUG) W "GOING TO CLOSE",! 447 N S1,E1,QCT,QCTMP 448 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML 449 I $D(QCXPATH) D ; XPATH PROVIDED 450 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX 451 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML 452 I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 453 . S S1=@QCXML@(0) 454 D QUEUE(QCBLIST,QCXML,S1,E1) 455 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) 456 Q 457 ; 458 INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE 459 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS 460 ; OMITTED, INSERTION WILL BE AT THE ROOT 461 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW 462 ; XML AT THE END OF THE XPATH POINT 463 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE 464 N INSBLD,INSTMP 465 I $G(DEBUG) W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! 466 I $G(DEBUG) F G1=1:1:@INSXML@(0) W @INSXML@(G1),! 467 I '$D(@INSXML@(1)) D ; INSERT INTO AN EMPTY ARRAY 468 . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT 469 I $D(@INSXML@(1)) D ; IF ORIGINAL ARRAY IS NOT EMPTY 470 . I '$D(@INSXML@(0)) S @INSXML@(0)=$O(@INSXML@(""),-1) ;SET LENGTH 471 . I $D(INSXPATH) D ; XPATH PROVIDED 472 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE 473 . . I $G(DEBUG) D PARY^C0CXPATH("INSBLD") 474 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 475 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH 476 . I '$D(@INSNEW@(0)) S @INSNEW@(0)=$O(@INSNEW@(""),-1) ;SIZE OF XML 477 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML 478 . I $D(INSXPATH) D ; XPATH PROVIDED 479 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH 480 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 481 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH 482 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST 483 . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE 484 Q 485 ; 486 INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW 487 ; INTO INNXML AT THE INNXPATH XPATH POINT 488 ; 489 N INNBLD,UXPATH 490 N INNTBUF 491 S INNTBUF=$NA(^TMP($J,"INNTBUF")) 492 I '$D(INNXPATH) D ; XPATH NOT PASSED 493 . S UXPATH="//" ; USE ROOT XPATH 494 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED 495 I '$D(@INNXML@(0)) D ; INNXML IS EMPTY 496 . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER 497 . D BUILD("INNBLD",INNXML) 498 I @INNXML@(0)>0 D ; NOT EMPTY 499 . D QOPEN("INNBLD",INNXML,UXPATH) ; 500 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML 501 . D QCLOSE("INNBLD",INNXML,UXPATH) 502 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER 503 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST 504 Q 505 ; 506 INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST 507 ; BUT XDEST AN XNEW ARE PASSED BY NAME 508 N XBLD,XTMP 509 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT 510 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST 511 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION 512 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 513 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION 514 I $G(DEBUG) D PARY("XDEST") 515 Q 516 ; 517 REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT 518 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE 519 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE 520 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") 521 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP 522 S OLD=$NA(^TMP($J,"REPLACE_OLD")) 523 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD 524 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS 525 S XFIRST=$P(XNODE,"^",1) 526 S XLAST=$P(XNODE,"^",2) 527 I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG 528 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE 529 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST 530 I RENEW'="" D ; NEW XML IS NOT NULL 531 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE 532 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW 533 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST 534 I $G(DEBUG) W "REPLACE PREBUILD",! 535 I $G(DEBUG) D PARY("REBLD") 536 D BUILD("REBLD","RTMP") 537 K @REXML ; KILL WHAT WAS THERE 538 D CP("RTMP",REXML) ; COPY IN THE RESULT 539 Q 540 ; 541 DELETE(REXML,REXPATH) ; DELETE THE XML AT THE XPATH POINT 542 ; REXML IS PASSED BY NAME XPATH IS A VALUE 543 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP 544 S OLD=$NA(^TMP($J,"REPLACE_OLD")) 545 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD 546 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS 547 S XFIRST=$P(XNODE,"^",1) 548 S XLAST=$P(XNODE,"^",2) 549 D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE 550 D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST 551 I $G(DEBUG) D PARY("REBLD") 552 D BUILD("REBLD","RTMP") 553 K @REXML ; KILL WHAT WAS THERE 554 D CP("RTMP",REXML) ; COPY IN THE RESULT 555 Q 556 ; 557 MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY 558 ; W "Reporting on the missing",! 559 ; W OARY 560 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q 561 N I 562 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT 563 F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY 564 . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE 565 . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY 566 . . Q 567 Q 568 ; 569 MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY 570 ; AND PUT THE RESULTS IN OXML 571 N XCNT 572 I '$D(DEBUG) S DEBUG=0 573 I '$D(IXML) W "MALFORMED XML PASSED TO MAP",! Q 574 I '$D(@IXML@(0)) D ; INITIALIZE COUNT 575 . S XCNT=$O(@IXML@(""),-1) 576 E S XCNT=@IXML@(0) ;COUNT 577 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q 578 N I,J,TNAM,TVAL,TSTR 579 S @OXML@(0)=XCNT ; TOTAL LINES IN OUTPUT 580 F I=1:1:XCNT D ; LOOP THROUGH WHOLE ARRAY 581 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT 582 . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? 583 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS 584 . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS 585 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! 586 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME 587 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED 588 . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? 589 . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD 590 . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE 591 . . . . E D DOFLD ; PROCESS A FIELD 592 . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE 593 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER 594 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES 595 . . I DEBUG W TSTR 596 I DEBUG W "MAPPED",! 597 Q 598 ; 599 DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE 600 ; 601 Q 602 ; 603 TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS 604 ; THEXML IS PASSED BY NAME 605 N I,J,TMPXML,DEL,FOUND,INTXT 606 S FOUND=0 607 S INTXT=0 608 I $G(DEBUG) W "DELETING EMPTY ELEMENTS",! 609 F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY 610 . S J=@THEXML@(I) 611 . I J["<text>" D 612 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM 613 . . I $G(DEBUG) W "IN HTML SECTION",! 614 . N JM,JP,JPX ; JMINUS AND JPLUS 615 . S JM=@THEXML@(I-1) ; LINE BEFORE 616 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM 617 . S JP=@THEXML@(I+1) ; LINE AFTER 618 . I INTXT=0 D ; IF NOT IN AN HTML SECTION 619 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH 620 . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES 621 . . . I $G(DEBUG) W I,J,JP,! 622 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 623 . . . S DEL(I)="" ; SET LINE TO DELETE 624 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE 625 . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE 626 . . . I $G(DEBUG) W I,J,! 627 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 628 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED 629 . . . I JM=JPX D ; 630 . . . . I $G(DEBUG) W I,JM_J_JPX,! 631 . . . . S DEL(I-1)="" 632 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL 633 ; . I J'["><" D PUSH("TMPXML",J) 634 I FOUND D ; NEED TO DELETE THINGS 635 . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES 636 . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED 637 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY 638 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY 639 Q FOUND 640 ; 641 UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML 642 ; XSEC IS A SECTION PASSED BY NAME 643 N XBLD,XTMP 644 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML 645 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 646 D CP("XTMP",XSEC) ; REPLACE PASSED XML 647 Q 648 ; 649 PARY(GLO,ZN) ;PRINT AN ARRAY 650 ; IF ZN=-1 NO LINE NUMBERS 651 N I 652 F I=1:1:@GLO@(0) D ; 653 . I $G(ZN)=-1 W @GLO@(I),! 654 . E W I_" "_@GLO@(I),! 655 Q 656 ; 657 H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY 658 ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE 659 I '$D(IPRE) S IPRE="" 660 N H2I S H2I="" 661 ; W $O(@IHASH@(H2I)),! 662 F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH 663 . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES 664 . . ;W H2I_"^"_@IHASH@(H2I),! 665 . . N IH,IHI 666 . . S IH=$NA(@IHASH@(H2I)) ; 667 . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR 668 . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE 669 . . S IHI="" ; INDEX INTO "M" MULTIPLES 670 . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE 671 . . . ; W @IH@(IHI) 672 . . . S IH3=$NA(@IH2@(IHI)) 673 . . . ; W "HEY",IH3,! 674 . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS 675 . . ; W IH,! 676 . . ; W "C0CZZ",! 677 . . ; W $NA(@IHASH@(H2I)),! 678 . . Q ; 679 . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I)) 680 . ; W @IARYRTN@(0),! 681 Q 682 ; 683 XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES 684 ; DEFINED IN INPUT XML XVIXML BY @@VAR@@ 685 ; XVRTN AND XVIXML ARE PASSED BY NAME 686 ; 687 N XVI,XVTMP,XVT 688 F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML 689 . S XVT=@XVIXML@(XVI) 690 . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI 691 D H2ARY(XVRTN,"XVTMP") 692 Q 693 ; 694 DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE 695 ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE 696 ; 697 N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED 698 I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE 699 . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP 700 . S DXUSE="DTMP" ; DXUSE IS NAME 701 E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE 702 . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP 703 . S DXUSE="DTMP" ; DXUSE IS NAME 704 E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE 705 N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE 706 D XVARS("DVARS",DXUSE) ; PULL OUT VARS 707 D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM 708 Q 709 ; 710 TEST ; Run all the test cases 711 D TESTALL^C0CUNIT("C0CXPAT0") 712 Q 713 ; 714 ZTEST(WHICH) ; RUN ONE SET OF TESTS 715 N ZTMP 716 S DEBUG=1 717 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 718 D ZTEST^C0CUNIT(.ZTMP,WHICH) 719 Q 720 ; 721 TLIST ; LIST THE TESTS 722 N ZTMP 723 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0") 724 D TLIST^C0CUNIT(.ZTMP) 725 Q 726 ; -
ccr/trunk/p/LA7QRY1.m
r508 r1336 1 LA7QRY1 2 3 4 5 6 CHKSC 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 SPEC 24 25 26 27 28 29 30 31 32 33 34 BUILDMSG 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 PID 64 65 66 67 68 69 70 71 72 73 74 75 76 ORC 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 OBR 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 OBX 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 1 LA7QRY1 ;DALOI/JMC - Lab HL7 Query Utility ;01/19/99 13:48 2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,61**;Sep 27, 1994;Build 31 3 ; 4 Q 5 ; 6 CHKSC ; Check search NLT/LOINC codes 7 ; 8 N J 9 ; 10 S J=0 11 F S J=$O(LA7SC(J)) Q:'J D 12 . N X 13 . S X=LA7SC(J) 14 . I $P(X,"^",2)="NLT",$D(^LAM("E",$P(X,"^"))) D Q 15 . . S ^TMP("LA7-NLT",$J,$P(X,"^"))="" 16 . I $P(X,"^",2)="LN",$D(^LAB(95.3,$P($P(X,"^"),"-"))) D Q 17 . . S ^TMP("LA7-LN",$J,$P($P(X,"^"),"-"))="" 18 . S LA7ERR(6)="Unknown search code "_$P(X,"^")_" passed" 19 . K LA7SC(J) 20 Q 21 ; 22 ; 23 SPEC ; Convert HL7 Specimen Codes to File #61, Topography codes 24 ; Find all topographies that use this HL7 specimen code 25 N J,K,L 26 ; 27 S J=0 28 F S J=$O(LA7SPEC(J)) Q:'J D 29 . S K=LA7SPEC(J),L=0 30 . F S L=$O(^LAB(61,"HL7",K,L)) Q:'L S ^TMP("LA7-61",$J,L)="" 31 Q 32 ; 33 ; 34 BUILDMSG ; Build HL7 message with result of query 35 ; 36 N HL,HLECH,HLFS,HLQ,LA,LA763,LA7ECH,LA7FS,LA7MSH,LA7NOMSG,LA7NTESN,LA7NVAF,LA7OBRSN,LA7OBXSN,LA7PIDSN,LA7ROOT,LA7X,X 37 ; 38 I $L($G(LA7HL7))'=5 S LA7HL7="|^\~&" 39 S (HL("FS"),HLFS,LA7FS)=$E(LA7HL7),(HL("ECH"),HLECH,LA7ECH)=$E(LA7HL7,2,5) 40 S (HLQ,HL("Q"))="""""" 41 ; Set flag to not send HL7 message 42 S LA7NOMSG=1 43 ; Create dummy MSH to pass HL7 delimiters 44 S LA7MSH(0)="MSH"_LA7FS_LA7ECH_LA7FS 45 D FILESEG^LA7VHLU(GBL,.LA7MSH) 46 ; 47 F X="AUTO-INST","LRDFN","LRIDT","SUB","HUID","NLT","RUID","SITE" S LA(X)="" 48 ; 49 ; Take search results and put in HL7 message structure 50 S LA7ROOT="^TMP(""LA7-QRY"",$J)",(LA7QUIT,LA7PIDSN)=0 51 ; F S LA7ROOT=$Q(@LA7ROOT) Q:LA7QUIT D ;change per John M 52 F S LA7ROOT=$Q(@LA7ROOT) Q:LA7ROOT="" D Q:LA7QUIT 53 . I $QS(LA7ROOT,1)'="LA7-QRY"!($QS(LA7ROOT,2)'=$J) S LA7QUIT=1 Q 54 . I LA("LRDFN")'=$QS(LA7ROOT,3) D PID S LA7OBRSN=0 55 . I LA("LRIDT")'=$QS(LA7ROOT,4) D ORC,OBR 56 . I LA("SUB")'=$QS(LA7ROOT,5) D ORC,OBR 57 . I LA("NLT")'=$P($QS(LA7ROOT,6),"!") D ORC,OBR 58 . D OBX 59 ; 60 Q 61 ; 62 ; 63 PID ; Build PID segment 64 ; 65 N LA7PID 66 ; 67 S (LA("LRDFN"),LRDFN)=$QS(LA7ROOT,3) 68 S LRDPF=$P(^LR(LRDFN,0),"^",2),DFN=$P(^(0),"^",3) 69 D DEM^LRX 70 D PID^LA7VPID(LA("LRDFN"),"",.LA7PID,.LA7PIDSN,.HL) 71 D FILESEG^LA7VHLU(GBL,.LA7PID) 72 S (LA("LRIDT"),LA("SUB"))="" 73 Q 74 ; 75 ; 76 ORC ; Build ORC segment 77 ; 78 N X 79 ; 80 S LA("LRIDT")=$QS(LA7ROOT,4),LA("SUB")=$QS(LA7ROOT,5) 81 S LA763(0)=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),0)) 82 S X=$G(^LR(LA("LRDFN"),LA("SUB"),LA("LRIDT"),"ORU")) 83 S LA("HUID")=$P(X,"^"),LA("SITE")=$P(X,"^",2),LA("RUID")=$P(X,"^",4) 84 I LA("HUID")="" S LA("HUID")=$P(LA763(0),"^",6) 85 S LA7NVAF=$$NVAF^LA7VHLU2(0),LA7NTESN=0 86 D ORC^LA7VORU 87 S LA("NLT")="" 88 ; 89 Q 90 ; 91 ; 92 OBR ; Build OBR segment 93 ; 94 N LA764,LA7NLT 95 ; 96 S (LA("NLT"),LA7NLT)=$P($QS(LA7ROOT,6),"!"),(LA764,LA("ORD"))="" 97 I $L(LA7NLT) D 98 . S LA764=+$O(^LAM("E",LA7NLT,0)) 99 . I LA764 S LA("ORD")=$$GET1^DIQ(64,LA764_",",.01) 100 I LA("SUB")="CH" D 101 . D OBR^LA7VORU 102 . D NTE^LA7VORU 103 . S LA7OBXSN=0 104 ; 105 Q 106 ; 107 ; 108 OBX ; Build OBX segment 109 ; 110 N LA7DATA,LA7VT 111 ; 112 S LA7NTESN=0 113 I LA("SUB")="MI" D MI^LA7VORU1 Q 114 I "CYEMSP"[LA("SUB") D AP^LA7VORU2 Q 115 ; 116 S LA7VT=$QS(LA7ROOT,7) 117 D OBX^LA7VOBX(LA("LRDFN"),LA("SUB"),LA("LRIDT"),LA7VT,.LA7DATA,.LA7OBXSN,LA7FS,LA7ECH) 118 I '$D(LA7DATA) Q 119 D FILESEG^LA7VHLU(GBL,.LA7DATA) 120 ; Send any test interpretation from file #60 121 D INTRP^LA7VORUA 122 ; 123 Q -
ccr/trunk/p/VWTIME.m
r1213 r1336 1 VWTIME 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 DIF(SD,ED) 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 BRIEF(SD,ED) 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 TDIFF(BF) 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 F2D(X) 209 210 211 212 213 H2D(X) 214 215 216 217 218 LONGAGE(VWAGE,VWDFN) 219 220 221 222 223 224 BRFAGE(VWAGE,VWDFN) 225 226 227 228 229 230 RPCREG 231 232 233 234 235 236 237 238 239 1 VWTIME ; Report Age in Time / Date;5:33 AM 11 Feb 2010 2 ;;1.0;WorldVistA;;WorldVistA 30-June-08;Build 2 3 ; 4 ;Modified from FOIA VISTA, 5 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 6 ;General Public License See attached copy of the License. 7 ; 8 ;This program is free software; you can redistribute it and/or modify 9 ;it under the terms of the GNU General Public License as published by 10 ;the Free Software Foundation; either version 2 of the License, or 11 ;(at your option) any later version. 12 ; 13 ;This program is distributed in the hope that it will be useful, 14 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 15 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 ;GNU General Public License for more details. 17 ; 18 ;You should have received a copy of the GNU General Public License along 19 ;with this program; if not, write to the Free Software Foundation, Inc., 20 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 21 ; 22 QUIT ; No Fall Through 23 ; ============= 24 ; FDT = First Date/Time (SD) 25 ; W $$DIF^VWTIME(3090512.1145) 26 DIF(SD,ED) ; Now a Call will look like the above 27 N BUF,DED,DSD,EH,EI,FTD 28 S SD=$G(SD),ED=$G(ED) 29 I ED="" D NOW^%DTC S ED=% 30 I SD<.00001 D NOW^%DTC S SD=% ; Invalid start date is set to now 31 S X=SD 32 D 33 . I SD="" S ER=99 Q 34 . ; 35 . ; Convert both Values to Fileman Time to Decimal. 36 . ; We are interested in just the differences 37 . ; 38 . I SD>1400000 D 39 . . S X=$$F2D(SD) 40 . . D H^%DTC 41 . . S SD=%H_","_$TR($J(%T,5)," ","0") 42 . .QUIT 43 . S DST=$$F2D(SD) 44 . S DET=$$F2D(ED) 45 .QUIT 46 ; Decimal Date/Times calculated in DST (start) and DET (end), 47 ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date 48 S (DTD,FTD)=DET-DST 49 ; Time Frames 50 ; 1 Minute = .000694444444444444444 51 ; 1 Hour = .0416666666666666666 52 ; 1 Day = 1 53 ; 1 WeeK = 7 54 ; 1 Month = 30.5 55 ; 1 Year = 365.249 56 N BUF,DAY,HR,MIN,MON,WK,YR 57 S BUF="" 58 S DAY=1 59 S SEP="" 60 D 61 . N HR,MON,YR,WEEK 62 . S MON=30.49,YR=365.249,HR=1/24,WEEK=7 63 . I FTD>(2*YR) D 64 . . S T=DTD\YR 65 . . S BUF=BUF_SEP_T_" Year" 66 . . S:T>1 BUF=BUF_"s" 67 . . S DTD=(DTD#YR),SEP=", " 68 . . .QUIT 69 . QUIT:FTD>(20*YR) 70 . ; 71 . ; Time Calculations 72 . I FTD>(4*MON) I FTD<(18*YR) D 73 . . S T=DTD\MON 74 . . S BUF=BUF_SEP_T_" Month" 75 . . S:T>1 BUF=BUF_"s" 76 . . S DTD=(DTD#MON),SEP=", " 77 . .QUIT 78 . QUIT:FTD>(18*YR) 79 . I FTD>29 I FTD<4*WEEK D 80 . . S T=DTD\WEEK 81 . . S BUF=BUF_SEP_T_" Week" 82 . . S:T>1 BUF=BUF_"s" 83 . . S DTD=(DTD#WEEK),SEP=", " 84 . .QUIT 85 . ; Time Calculations 86 . I FTD<29 I DTD'<2 D 87 . . S T=DTD\1 88 . . S BUF=BUF_SEP_T_" Day" 89 . . S:T>1 BUF=BUF_"s" 90 . . S DTD=(DTD#DAY),SEP=", " 91 . .QUIT 92 . I DTD>.999999&(FTD<4) D 93 . . S T=DTD\HR 94 . . S BUF=BUF_SEP_T_" Hour" 95 . . S:T>1 BUF=BUF_"s" 96 . . S DTD=(DTD#HR),SEP=", " 97 . .QUIT 98 . D:(FTD<4.00000001) 99 . . N MIN,HR 100 . . S HR=1/24,SEP=$G(SEP) 101 . . S MIN=HR/60 102 . . ; 103 . . I DTD>MIN D 104 . . . S T=DTD\MIN 105 . . . S BUF=BUF_SEP_T_" Minute" 106 . . . S:T>1 BUF=BUF_"s" 107 . . . S DTD=(DTD#MIN),SEP=", " 108 . .QUIT 109 . . ; 110 . . S SEC=MIN/60 111 . . I DTD>SEC D 112 . . . S T=DTD\SEC 113 . . . S BUF=BUF_SEP_T_" Second" 114 . . . S:T>1 BUF=BUF_"s" 115 . . . S DTD=(DTD#SEC),SEP=", " 116 . . .QUIT 117 . .QUIT 118 . ; I DTD S BUF=BUF_" Less than a Minute" 119 .QUIT 120 QUIT BUF 121 ; ========== 122 ; W $$BRIEF^VWTIME(DOB) >>> Years^Months^Weeks^Days^Hours^Minutes^Seconds 123 BRIEF(SD,ED) ; Now a Call will look like the above 124 N BUF,DED,DSD,EH,EI,FTD,BUF 125 S SD=$G(SD),ED=$G(ED) 126 I ED="" D NOW^%DTC S ED=% 127 S:SD<2 SD="" 128 S BUF="INVALID INPUT" 129 D:SD ; SD has been checked and passed if it passes here 130 . S X=SD 131 . ; 132 . ; Convert both Values to Fileman Time to Decimal. 133 . ; We are interested in just the differences 134 . ; 135 . ; I SD>1400000 D 136 . ; . S X=$$F2D(SD) 137 . ; . D H^%DTC 138 . ; . S SD=%H_","_$TR($J(%T,5)," ","0") 139 . ; .QUIT 140 . ; If we get here, we have the ST and ET defined and ready 141 . S DST=$$F2D(SD) 142 . S DET=$$F2D(ED) 143 . D TDIFF(.BUF) 144 .QUIT 145 QUIT BUF 146 ; =========== 147 TDIFF(BF) ; Time Difference formulation 148 ; Decimal Date/Times calculated in DST (start) and DET (end), 149 ; differeence of DET-DST is FTD - First Time and Date, DTD - Declining Time and Date 150 S (DTD,FTD)=DET-DST 151 ; Time Frames 152 ; 1 Minute = .000694444444444444444 153 ; 1 Hour = .0416666666666666666 154 ; 1 Day = 1 155 ; 1 WeeK = 7 156 ; 1 Month = 30.5 157 ; 1 Year = 365.249 158 N DAY,HR,MIN,MON,WK,YR 159 S $P(BF,"^",7)="" 160 S DAY=1 161 S SEP="" 162 D 163 . N HR,MON,YR,WEEK 164 . S MON=30.49,YR=365.249,HR=1/24,WEEK=7 165 . I FTD>(2*YR) D 166 . . S $P(BF,"^")=DTD\YR 167 . . S DTD=(DTD#YR) 168 . .QUIT 169 . ; 170 . ; Time Calculations 171 . I FTD>(4*MON) I FTD<(18*YR) D 172 . . S $P(BF,"^",2)=DTD\MON 173 . . S DTD=(DTD#MON) 174 . .QUIT 175 . D ; I FTD>29 I FTD<4*WEEK D 176 . . S $P(BF,"^",3)=DTD\WEEK 177 . . S DTD=(DTD#WEEK) 178 . .QUIT 179 . ; Time Calculations 180 . D ; I FTD<29 I DTD'<2 D 181 . . S $P(BF,"^",4)=DTD\1 182 . . S DTD=(DTD#DAY) 183 . .QUIT 184 . D ; I DTD>.999999&(FTD<4) D 185 . . S $P(BF,"^",5)=DTD\HR 186 . . S DTD=(DTD#HR) 187 . .QUIT 188 . S MIN=1/(24*60) 189 . D ; :(FTD<4.00000001) 190 . . N HR 191 . . S HR=1/24 192 . . S MIN=HR/60 193 . . ; 194 . . ; I DTD>MIN D 195 . . S $P(BF,"^",6)=DTD\MIN 196 . . S DTD=(DTD#MIN) 197 . .QUIT 198 . . ; 199 . S SEC=MIN/60 200 . ; I DTD>SEC D 201 . S $P(BF,"^",7)=DTD\SEC 202 . S DTD=(DTD#SEC) 203 . .QUIT 204 . ; I DTD S BF=BF_" Less than a Minute" 205 .QUIT 206 QUIT 207 ; ========== 208 F2D(X) ; Conver FM Date/Time to Decimal 209 N %H,%T,%Y 210 D H^%DTC 211 QUIT $$H2D(%H_","_%T) 212 ; ======== 213 H2D(X) ; Convert Horolog to Decimal Days 214 N D,T 215 S D=$P(X,","),T=$P(X,",",2)/86400 216 QUIT D+T 217 ; ============= 218 LONGAGE(VWAGE,VWDFN) ; RPC FOR LONG AGE 219 N VWDOB 220 S VWDOB=$P(^DPT(VWDFN,0),"^",3) 221 S VWAGE=$$DIF(VWDOB) 222 QUIT 223 ; ============= 224 BRFAGE(VWAGE,VWDFN) ; RPC FOR BRIEF AGE 225 N VWDOB 226 S VWDOB=$P(^DPT(VWDFN,0),"^",3) 227 S VWAGE=$$BRIEF(VWDOB) 228 QUIT 229 ; ============= 230 RPCREG ; Register NEW RPCs 231 N MENU,RPC,FDA,FDAIEN,ERR,DIERR 232 S MENU="OR CPRS GUI CHART" 233 F RPC="VWTIME LONG AGE","VWTIME BRIEF AGE" D 234 . S FDA(19,"?1,",.01)=MENU 235 . S FDA(19.05,"?+2,?1,",.01)=RPC 236 . D UPDATE^DIE("E","FDA","FDAIEN","ERR") 237 .QUIT 238 QUIT 239 ; ============
Note:
See TracChangeset
for help on using the changeset viewer.
