- Timestamp:
- Oct 3, 2008, 10:57:33 PM (16 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/CCRDPT.m
r122 r175 1 CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;0.1;CCRCCD;;Jun 15, 2008; 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 ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and 20 ; DESTROY to clean-up. 21 ; The first line of every routine tests if the global exists. 22 ; 23 ; CCRDPT 83 lines CCRCCD/SMH - Routines to Extract Patient Data for 24 ; INIT 9 lines Copy DFN global to a local variable 25 ; DESTROY 6 lines Kill local variable 26 ; FAMILY 6 lines Family Name 27 ; GIVEN 6 lines Given Name 28 ; MIDDLE 6 lines Middle Name 29 ; SUFFIX 6 lines Suffix Name 30 ; DISPNAME 5 lines Display Name 31 ; DOB 6 lines Date of Birth 32 ; GENDER 4 lines Get Gender 33 ; SSN 4 lines Get SSN for ID 34 ; ADDRTYPE 4 lines Get Home Address 35 ; ADDR1 4 lines Get Home Address line 1 36 ; ADDR2 5 lines Get Home Address line 2 37 ; CITY 4 lines Get City for Home Address 38 ; STATE 11 lines Get State for Home Address 39 ; ZIP 4 lines Get Zip code for Home Address 40 ; COUNTY 4 lines Get County for our Address 41 ; COUNTRY 4 lines Get Country for our Address 42 ; RESTEL 4 lines Residential Telephone 43 ; WORKTEL 4 lines Work Telephone 44 ; EMAIL 4 lines Email Adddress 45 ; CELLTEL 4 lines Cell Phone 46 ; NOK1FAM 6 lines Next of Kin 1 (NOK1) Family Name 47 ; NOK1GIV 6 lines NOK1 Given Name 48 ; NOK1MID 6 lines NOK1 Middle Name 49 ; NOK1SUF 6 lines NOK1 Suffi Name 50 ; NOK1DISP 5 lines NOK1 Display Name 51 ; NOK1REL 4 lines NOK1 Relationship to the patient 52 ; NOK1ADD1 4 lines NOK1 Address 1 53 ; NOK1ADD2 5 lines NOK1 Address 2 54 ; NOK1CITY 4 lines NOK1 City 55 ; NOK1STAT 5 lines NOK1 State 56 ; NOK1ZIP 4 lines NOK1 Zip Code 57 ; NOK1HTEL; 4 lines NOK1 Home Telephone 58 ; NOK1WTEL; 4 lines NOK1 Work Telephone 59 ; NOK1SAME; 4 lines Is NOK1's Address the same the patient? 60 ; NOK2FAM 6 lines NOK2 Family Name 61 ; NOK2GIV 6 lines NOK2 Given Name 62 ; NOK2MID 6 lines NOK2 Middle Name 63 ; NOK2SUF 5 lines NOK2 Suffi Name 64 ; NOK2DISP 5 lines NOK2 Display Name 65 ; NOK2REL 4 lines NOK2 Relationship to the patient 66 ; NOK2ADD1 4 lines NOK2 Address 1 67 ; NOK2ADD2 5 lines NOK2 Address 2 68 ; NOK2CITY 4 lines NOK2 City 69 ; NOK2STAT 5 lines NOK2 State 70 ; NOK2ZIP 4 lines NOK2 Zip Code 71 ; NOK2HTEL; 4 lines NOK2 Home Telephone 72 ; NOK2WTEL; 4 lines NOK2 Work Telephone 73 ; NOK2SAME; 4 lines Is NOK2's Address the same the patient? 74 ; EMERFAM 6 lines Emergency Contact (EMER) Family Name 75 ; EMERGIV 6 lines EMER Given Name 76 ; EMERMID 6 lines EMER Middle Name 77 ; EMERSUF 5 lines EMER Suffi Name 78 ; EMERDISP 5 lines EMER Display Name 79 ; EMERREL 4 lines EMER Relationship to the patient 80 ; EMERADD1 4 lines EMER Address 1 81 ; EMERADD2 5 lines EMER Address 2 82 ; EMERCITY 4 lines EMER City 83 ; EMERSTAT 5 lines EMER State 84 ; EMERZIP 4 lines EMER Zip Code 85 ; EMERHTEL; 4 lines EMER Home Telephone 86 ; EMERWTEL; 4 lines EMER Work Telephone 87 ; EMERSAME; 4 lines Is EMER's Address the same the NOK? 88 ; 89 W "No Entry at top!" Q 90 ; The following is a map of the relevant data in the patient global. 91 ; 92 ; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^ 93 ; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07) 94 ; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09) 95 ; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092) 96 ; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE] 97 ; ==>[12P:5] ^ ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^ 98 ; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO 99 ; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081) 100 ; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^ 101 ; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR 102 ; ==>[21S] ^ 103 ; ^DPT(D0,.01,0)=^2.01^^ (#1) ALIAS 104 ; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS 105 ; ==>COMPONENTS [3P:20] ^ 106 ; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS 107 ; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114) 108 ; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^ 109 ; ==>(#.117) COUNTY [7N] ^ ^ ^ ^ ^ (#.1112) ZIP+4 [12F] ^ 110 ; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE 111 ; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD 112 ; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200] 113 ; ==>^ 114 ; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY 115 ; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F] 116 ; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE 117 ; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY 118 ; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE 119 ; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219) 120 ; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS 121 ; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113) 122 ; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^ 123 ; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^ 124 ; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER 125 ; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER 126 ; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL 127 ; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE 128 ; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139) 129 ; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER 130 ; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE 131 ; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313) 132 ; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE 133 ; ==>SITE [14P:4] ^ 134 ; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO 135 ; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214) 136 ; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE 137 ; ==>3] [5F] ^ 138 ; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP 139 ; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS 140 ; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F] 141 ; ==>^ 142 ; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192) 143 ; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS 144 ; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^ 145 ; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY 146 ; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^ 147 ; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS 148 ; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^ 149 ; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP 150 ; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2] 151 ; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255) 152 ; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S 153 ; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258) 154 ; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^ ^ ^ ^ ^ ^ (#.2514) 155 ; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS 156 ; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^ 157 ; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^ 158 ; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET 159 ; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F] 160 ; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP 161 ; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER. 162 ; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER 163 ; ==>[11F] ^DFN) ; Copy DFN global to a local variable; PUBLIC 164 ; INPUT: Patient IEN (DFN) 165 ; OUTPUT: PT in the Symbol Table, representing the patient global 166 ; Instead of accessing a global each single read (SLOOOOW) 167 ; read it off a local variable stored in Memory. 168 INIT(DFN) ; 169 M PT=^DPT(DFN) 170 Q 171 ; 172 DESTROY ; Kill local variable; PUBLIC 173 ; INPUT: None 174 ; OUTPUT: Kill PT from the Symbol Table after you are done 175 K PT 176 Q 177 ; 178 FAMILY() ; Family Name; PUBLIC; Extrinsic 179 ; PREREQ: PT Defined 180 Q:$G(PT(0))="" "" 181 N NAME S NAME=$P(PT(0),"^",1) 182 D NAMECOMP^XLFNAME(.NAME) 183 Q NAME("FAMILY") 184 ; 185 GIVEN() ; Given Name; PUBLIC; Extrinsic 186 ; PREREQ: PT Defined 187 Q:$G(PT(0))="" "" 188 N NAME S NAME=$P(PT(0),"^",1) 189 D NAMECOMP^XLFNAME(.NAME) 190 Q NAME("GIVEN") 191 ; 192 MIDDLE() ; Middle Name; PUBLIC; Extrinsic 193 ; PREREQ: PT Defined 194 Q:$G(PT(0))="" "" 195 N NAME S NAME=$P(PT(0),"^",1) 196 D NAMECOMP^XLFNAME(.NAME) 197 Q NAME("MIDDLE") 198 ; 199 SUFFIX() ; Suffi Name; PUBLIC; Extrinsic 200 ; PREREQ: PT Defined 201 Q:$G(PT(0))="" "" 202 N NAME S NAME=$P(PT(0),"^",1) 203 D NAMECOMP^XLFNAME(.NAME) 204 Q NAME("SUFFIX") 205 ; 206 DISPNAME() ; Display Name; PUBLIC; Extrinsic 207 ; PREREQ: PT Defined 208 Q:$G(PT(0))="" "" 209 N NAME S NAME=$P(PT(0),"^",1) 210 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 211 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 212 DOB() ; Date of Birth; PUBLIC; Extrinsic 213 ; PREREQ: PT Defined 214 Q:$G(PT(0))="" "" 215 N DOB S DOB=$P(PT(0),"^",3) 216 ; Date in FM Date Format. Convert to UTC/ISO 8601. 217 Q $$FMDTOUTC^CCRUTIL(DOB,"D") 218 ; 219 GENDER() ; Get Gender; PUBLIC; Extrinsic 220 ; PREREQ: PT Defined 221 Q:$G(PT(0))="" "" 222 Q $P(PT(0),"^",2) 223 ; 224 SSN() ; Get SSN for ID; PUBLIC; Extrinsic 225 ; PREREQ: PT Defined 226 Q:$G(PT(0))="" "" 227 Q $P(PT(0),"^",9) 228 ; 229 ADDRTYPE() ; Get Home Address; PUBLIC; Extrinsic 230 ; Vista only stores a home address for the patient. 231 Q:$G(PT(0))="" "" 232 Q "Home" 233 ; 234 ADDR1() ; Get Home Address line 1; PUBLIC; Extrinsic 235 ; PREREQ: PT Defined 236 Q:$G(PT(.11))="" "" 237 Q $P(PT(.11),"^",1) 238 ; 239 ADDR2() ; Get Home Address line 2; PUBLIC; Extrinsic 240 ; PREREQ: PT Defined 241 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise 242 Q:$G(PT(.11))="" "" 243 ; If the thrid address is empty, just return the 2nd. 244 ; If the 2nd is empty, we don't lose, b/c it will return "" 245 ; This is so that we won't produce a comma if there is no 3rd addr. 246 Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2) 247 Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3) 248 ; 249 CITY() ; Get City for Home Address; PUBLIC; Extrinsic 250 ; PREREQ: PT Defined 251 Q:$G(PT(.11))="" "" 252 Q $P(PT(.11),"^",4) 253 ; 254 STATE() ; Get State for Home Address; PUBLIC; Extrinsic 255 ; PREREQ: PT Defined 256 Q:$G(PT(.11))="" "" 257 ; State is stored as a pointer 258 N STATENUM S STATENUM=$P(PT(.11),"^",5) 259 ; 260 ; State File Global is below 261 ; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE 262 ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2) 263 ; ==>US STATE OR POSSESSION [6S] ^ 264 Q:STATENUM="" "" ; To prevent global undefined below if no state 265 Q $P(^DIC(5,STATENUM,0),"^",1) 266 ; 267 ZIP() ; Get Zip code for Home Address; PUBLIC; Extrinsic 268 ; PREREQ: PT Defined 269 Q:$G(PT(.11))="" "" 270 Q $P(PT(.11),"^",6) 271 ; 272 COUNTY() ; Get County for our Address; PUBLIC; Extrinsic 273 ; PREREQ: PT Defined 274 Q:$G(PT(.11))="" "" 275 Q $P(PT(.11),"^",7) 276 ; 277 COUNTRY() ; Get Country for our Address; PUBLIC; Extrinsic 278 ; Unfortunately, I can't find where that is stored, so the inevitable... 279 Q:$G(PT(.11))="" "" 280 Q "USA" 281 ; 282 RESTEL() ; Residential Telephone; PUBLIC; Extrinsic 283 ; PREREQ: PT Defined 284 Q:$G(PT(.13))="" "" 285 Q $P(PT(.13),"^",1) 286 ; 287 WORKTEL() ; Work Telephone; PUBLIC; Extrinsic 288 ; PREREQ: PT Defined 289 Q:$G(PT(.13))="" "" 290 Q $P(PT(.13),"^",2) 291 ; 292 EMAIL() ; Email Adddress; PUBLIC; Extrinsic 293 ; PREREQ: PT Defined 294 Q:$G(PT(.13))="" "" 295 Q $P(PT(.13),"^",3) 296 ; 297 CELLTEL() ; Cell Phone; PUBLIC; Extrinsic 298 ; PREREQ: PT Defined 299 Q:$G(PT(.13))="" "" 300 Q $P(PT(.13),"^",4) 301 ; 302 NOK1FAM() ; Next of Kin 1 (NOK1) Family Name; PUBLIC; Extrinsic 303 ; PREREQ: PT Defined 304 Q:$G(PT(.21))="" "" 305 N NAME S NAME=$P(PT(.21),"^",1) 306 D NAMECOMP^XLFNAME(.NAME) 307 Q NAME("FAMILY") 308 ; 309 NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic 310 ; PREREQ: PT Defined 311 Q:$G(PT(.21))="" "" 312 N NAME S NAME=$P(PT(.21),"^",1) 313 D NAMECOMP^XLFNAME(.NAME) 314 Q NAME("GIVEN") 315 ; 316 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic 317 ; PREREQ: PT Defined 318 Q:$G(PT(.21))="" "" 319 N NAME S NAME=$P(PT(.21),"^",1) 320 D NAMECOMP^XLFNAME(.NAME) 321 Q NAME("MIDDLE") 322 ; 323 NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic 324 ; PREREQ: PT Defined 325 Q:$G(PT(.21))="" "" 326 N NAME S NAME=$P(PT(.21),"^",1) 327 D NAMECOMP^XLFNAME(.NAME) 328 Q NAME("SUFFIX") 329 ; 330 NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic 331 ; PREREQ: PT Defined 332 Q:$G(PT(.21))="" "" 333 N NAME S NAME=$P(PT(.21),"^",1) 334 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 335 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 336 NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic 337 ; PREREQ: PT Defined 338 Q:$G(PT(.21))="" "" 339 Q $P(PT(.21),"^",2) 340 ; 341 NOK1ADD1() ; NOK1 Address 1; PUBLIC; Extrinsic 342 ; PREREQ: PT Defined 343 Q:$G(PT(.21))="" "" 344 Q $P(PT(.21),"^",3) 345 ; 346 NOK1ADD2() ; NOK1 Address 2; PUBLIC; Extrinsic 347 ; PREREQ: PT Defined 348 ; As before, CCR only allows two fileds for the address, so we have to compromise 349 Q:$G(PT(.21))="" "" 350 ; If the thrid address is empty, just return the 2nd. 351 ; If the 2nd is empty, we don't lose, b/c it will return "" 352 ; This is so that we won't produce a comma if there is no 3rd addr. 353 Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4) 354 Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5) 355 ; 356 NOK1CITY() ; NOK1 City; PUBLIC; Extrinsic 357 ; PREREQ: PT Defined 358 Q:$G(PT(.21))="" "" 359 Q $P(PT(.21),"^",6) 360 ; 361 NOK1STAT() ; NOK1 State; PUBLIC; Extrinsic 362 ; PREREQ: PT Defined 363 Q:$G(PT(.21))="" "" 364 N STATENUM S STATENUM=$P(PT(.21),"^",7) 365 Q:STATENUM="" "" 366 Q $P(^DIC(5,STATENUM,0),"^",1) 367 ; 368 NOK1ZIP() ; NOK1 Zip Code; PUBLIC; Extrinsic 369 ; PREREQ: PT Defined 370 Q:$G(PT(.21))="" "" 371 Q $P(PT(.21),"^",8) 372 ; 373 NOK1HTEL() ; NOK1 Home Telephone; PUBLIC; Extrinsic 374 ; PREREQ: PT Defined 375 Q:$G(PT(.21))="" "" 376 Q $P(PT(.21),"^",9) 377 ; 378 NOK1WTEL() ; NOK1 Work Telephone; PUBLIC; Extrinsic 379 ; PREREQ: PT Defined 380 Q:$G(PT(.21))="" "" 381 Q $P(PT(.21),"^",11) 382 ; 383 NOK1SAME() ; Is NOK1's Address the same the patient?; PUBLIC; Extrinsic 384 ; PREREQ: PT Defined 385 Q:$G(PT(.21))="" "" 386 Q $P(PT(.21),"^",10) 387 ; 388 NOK2FAM() ; NOK2 Family Name; PUBLIC; Extrinsic 389 ; PREREQ: PT Defined 390 Q:$G(PT(.211))="" "" 391 N NAME S NAME=$P(PT(.211),"^",1) 392 D NAMECOMP^XLFNAME(.NAME) 393 Q NAME("FAMILY") 394 ; 395 NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined 396 Q:$G(PT(.211))="" "" 397 N NAME S NAME=$P(PT(.211),"^",1) 398 D NAMECOMP^XLFNAME(.NAME) 399 Q NAME("GIVEN") 400 ; 401 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic 402 ; PREREQ: PT Defined 403 Q:$G(PT(.211))="" "" 404 N NAME S NAME=$P(PT(.211),"^",1) 405 D NAMECOMP^XLFNAME(.NAME) 406 Q NAME("MIDDLE") 407 ; 408 NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic 409 ; PREREQ: PT Defined 410 Q:$G(PT(.211))="" "" 411 N NAME S NAME=$P(PT(.211),"^",1) 412 D NAMECOMP^XLFNAME(.NAME) 413 Q NAME("SUFFIX") 414 NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic 415 ; PREREQ: PT Defined 416 Q:$G(PT(.211))="" "" 417 N NAME S NAME=$P(PT(.211),"^",1) 418 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 419 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 420 NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic 421 ; PREREQ: PT Defined 422 Q:$G(PT(.211))="" "" 423 Q $P(PT(.211),"^",2) 424 ; 425 NOK2ADD1() ; NOK2 Address 1; PUBLIC; Extrinsic 426 ; PREREQ: PT Defined 427 Q:$G(PT(.211))="" "" 428 Q $P(PT(.211),"^",3) 429 ; 430 NOK2ADD2() ; NOK2 Address 2; PUBLIC; Extrinsic 431 ; PREREQ: PT Defined 432 ; As before, CCR only allows two fileds for the address, so we have to compromise 433 Q:$G(PT(.211))="" "" 434 ; If the thrid address is empty, just return the 2nd. 435 ; If the 2nd is empty, we don't lose, b/c it will return "" 436 ; This is so that we won't produce a comma if there is no 3rd addr. 437 Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4) 438 Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5) 439 ; 440 NOK2CITY() ; NOK2 City; PUBLIC; Extrinsic 441 ; PREREQ: PT Defined 442 Q:$G(PT(.211))="" "" 443 Q $P(PT(.211),"^",6) 444 ; 445 NOK2STAT() ; NOK2 State; PUBLIC; Extrinsic 446 ; PREREQ: PT Defined 447 Q:$G(PT(.211))="" "" 448 N STATENUM S STATENUM=$P(PT(.211),"^",7) 449 Q:STATENUM="" "" ; To prevent global undefined below if no state 450 Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above 451 ; 452 NOK2ZIP() ; NOK2 Zip Code; PUBLIC; Extrinsic 453 ; PREREQ: PT Defined 454 Q:$G(PT(.211))="" "" 455 Q $P(PT(.211),"^",8) 456 ; 457 NOK2HTEL() ; NOK2 Home Telephone; PUBLIC; Extrinsic 458 ; PREREQ: PT Defined 459 Q:$G(PT(.211))="" "" 460 Q $P(PT(.211),"^",9) 461 ; 462 NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic 463 ; PREREQ: PT Defined 464 Q:$G(PT(.211))="" "" 465 Q $P(PT(.211),"^",11) 466 ; 467 NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic 468 ; PREREQ: PT Defined 469 Q:$G(PT(.211))="" "" 470 Q $P(PT(.211),"^",10) 471 ; 472 EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic 473 ; PREREQ: PT Defined 474 Q:$G(PT(.33))="" "" 475 N NAME S NAME=$P(PT(.33),"^",1) 476 D NAMECOMP^XLFNAME(.NAME) 477 Q NAME("FAMILY") 478 ; 479 EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic 480 ; PREREQ: PT Defined 481 Q:$G(PT(.33))="" "" 482 N NAME S NAME=$P(PT(.33),"^",1) 483 D NAMECOMP^XLFNAME(.NAME) 484 Q NAME("GIVEN") 485 ; 486 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic 487 ; PREREQ: PT Defined 488 Q:$G(PT(.33))="" "" 489 N NAME S NAME=$P(PT(.33),"^",1) 490 D NAMECOMP^XLFNAME(.NAME) 491 Q NAME("MIDDLE") 492 ; 493 EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic 494 ; PREREQ: PT Defined 495 Q:$G(PT(.33))="" "" 496 N NAME S NAME=$P(PT(.33),"^",1) 497 D NAMECOMP^XLFNAME(.NAME) 498 Q NAME("SUFFIX") 499 EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic 500 ; PREREQ: PT Defined 501 Q:$G(PT(.33))="" "" 502 N NAME S NAME=$P(PT(.33),"^",1) 503 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 504 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 505 EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic 506 ; PREREQ: PT Defined 507 Q:$G(PT(.33))="" "" 508 Q $P(PT(.33),"^",2) 509 ; 510 EMERADD1() ; EMER Address 1; PUBLIC; Extrinsic 511 ; PREREQ: PT Defined 512 Q:$G(PT(.33))="" "" 513 Q $P(PT(.33),"^",3) 514 ; 515 EMERADD2() ; EMER Address 2; PUBLIC; Extrinsic 516 ; PREREQ: PT Defined 517 ; As before, CCR only allows two fileds for the address, so we have to compromise 518 Q:$G(PT(.33))="" "" 519 ; If the thrid address is empty, just return the 2nd. 520 ; If the 2nd is empty, we don't lose, b/c it will return "" 521 ; This is so that we won't produce a comma if there is no 3rd addr. 522 Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4) 523 Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5) 524 ; 525 EMERCITY() ; EMER City; PUBLIC; Extrinsic 526 ; PREREQ: PT Defined 527 Q:$G(PT(.33))="" "" 528 Q $P(PT(.33),"^",6) 529 ; 530 EMERSTAT() ; EMER State; PUBLIC; Extrinsic 531 ; PREREQ: PT Defined 532 Q:$G(PT(.33))="" "" 533 N STATENUM S STATENUM=$P(PT(.33),"^",7) 534 Q:STATENUM="" "" ; To prevent global undefined below if no state 535 Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above 536 ; 537 EMERZIP() ; EMER Zip Code; PUBLIC; Extrinsic 538 ; PREREQ: PT Defined 539 Q:$G(PT(.33))="" "" 540 Q $P(PT(.33),"^",8) 541 ; 542 EMERHTEL() ; EMER Home Telephone; PUBLIC; Extrinsic 543 ; PREREQ: PT Defined 544 Q:$G(PT(.33))="" "" 545 Q $P(PT(.33),"^",9) 546 ; 547 EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic 548 ; PREREQ: PT Defined 549 Q:$G(PT(.33))="" "" 550 Q $P(PT(.33),"^",11) 551 ; 552 EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic 553 ; PREREQ: PT Defined 554 Q:$G(PT(.33))="" "" 555 Q $P(PT(.33),"^",10) 556 ; 1 CCRDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 ;;0.2;CCRCCD;;Jun 15, 2008; 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 ; CCRDPT CCRCCD/SMH - Routines to Extract Patient Data for 17 ; FAMILY Family Name 18 ; GIVEN Given Name 19 ; MIDDLE Middle Name 20 ; SUFFIX Suffix Name 21 ; DISPNAME Display Name 22 ; DOB Date of Birth 23 ; GENDER Get Gender 24 ; SSN Get SSN for ID 25 ; ADDRTYPE Get Home Address 26 ; ADDR1 Get Home Address line 1 27 ; ADDR2 Get Home Address line 2 28 ; CITY Get City for Home Address 29 ; STATE Get State for Home Address 30 ; ZIP Get Zip code for Home Address 31 ; COUNTY Get County for our Address 32 ; COUNTRY Get Country for our Address 33 ; RESTEL Residential Telephone 34 ; WORKTEL Work Telephone 35 ; EMAIL Email Adddress 36 ; CELLTEL Cell Phone 37 ; NOK1FAM Next of Kin 1 (NOK1) Family Name 38 ; NOK1GIV NOK1 Given Name 39 ; NOK1MID NOK1 Middle Name 40 ; NOK1SUF NOK1 Suffi Name 41 ; NOK1DISP NOK1 Display Name 42 ; NOK1REL NOK1 Relationship to the patient 43 ; NOK1ADD1 NOK1 Address 1 44 ; NOK1ADD2 NOK1 Address 2 45 ; NOK1CITY NOK1 City 46 ; NOK1STAT NOK1 State 47 ; NOK1ZIP NOK1 Zip Code 48 ; NOK1HTEL NOK1 Home Telephone 49 ; NOK1WTEL NOK1 Work Telephone 50 ; NOK1SAME Is NOK1's Address the same the patient? 51 ; NOK2FAM NOK2 Family Name 52 ; NOK2GIV NOK2 Given Name 53 ; NOK2MID NOK2 Middle Name 54 ; NOK2SUF NOK2 Suffi Name 55 ; NOK2DISP NOK2 Display Name 56 ; NOK2REL NOK2 Relationship to the patient 57 ; NOK2ADD1 NOK2 Address 1 58 ; NOK2ADD2 NOK2 Address 2 59 ; NOK2CITY NOK2 City 60 ; NOK2STAT NOK2 State 61 ; NOK2ZIP NOK2 Zip Code 62 ; NOK2HTEL NOK2 Home Telephone 63 ; NOK2WTEL NOK2 Work Telephone 64 ; NOK2SAME Is NOK2's Address the same the patient? 65 ; EMERFAM Emergency Contact (EMER) Family Name 66 ; EMERGIV EMER Given Name 67 ; EMERMID EMER Middle Name 68 ; EMERSUF EMER Suffi Name 69 ; EMERDISP EMER Display Name 70 ; EMERREL EMER Relationship to the patient 71 ; EMERADD1 EMER Address 1 72 ; EMERADD2 EMER Address 2 73 ; EMERCITY EMER City 74 ; EMERSTAT EMER State 75 ; EMERZIP EMER Zip Code 76 ; EMERHTEL EMER Home Telephone 77 ; EMERWTEL EMER Work Telephone 78 ; EMERSAME Is EMER's Address the same the NOK? 79 ; 80 W "No Entry at top!" Q 81 ; 82 ;**Revision History** 83 ; - June 15, 08: v0.1 using merged global 84 ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes. 85 ; 86 ; All methods are Public and Extrinsic 87 ; All calls use Fileman file 2 (Patient). 88 ; You can obtain field numbers using the data dictionary 89 ; 90 FAMILY(DFN) ; Family Name 91 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 92 D NAMECOMP^XLFNAME(.NAME) 93 Q NAME("FAMILY") 94 GIVEN(DFN) ; Given Name 95 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 96 D NAMECOMP^XLFNAME(.NAME) 97 Q NAME("GIVEN") 98 MIDDLE(DFN) ; Middle Name 99 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 100 D NAMECOMP^XLFNAME(.NAME) 101 Q NAME("MIDDLE") 102 SUFFIX(DFN) ; Suffi Name 103 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 104 D NAMECOMP^XLFNAME(.NAME) 105 Q NAME("SUFFIX") 106 DISPNAME(DFN) ; Display Name 107 N NAME S NAME=$$GET1^DIQ(2,DFN,.01) 108 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 109 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 110 DOB(DFN) ; Date of Birth 111 N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I") 112 ; Date in FM Date Format. Convert to UTC/ISO 8601. 113 Q $$FMDTOUTC^CCRUTIL(DOB,"D") 114 GENDER(DFN) ; Gender/Sex 115 Q $$GET1^DIQ(2,DFN,.02) ; 116 SSN(DFN) ; SSN 117 Q $$GET1^DIQ(2,DFN,.09) 118 ADDRTYPE(DFN) ; Address Type 119 ; Vista only stores a home address for the patient. 120 Q "Home" 121 ADDR1(DFN) ; Get Home Address line 1 122 Q $$GET1^DIQ(2,DFN,.111) 123 ADDR2(DFN) ; Get Home Address line 2 124 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise 125 N ADDLN2,ADDLN3 126 S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113) 127 Q:ADDLN3="" ADDLN2 128 Q ADDLN2_", "_ADDLN3 129 CITY(DFN) ; Get City for Home Address 130 Q $$GET1^DIQ(2,DFN,.114) 131 STATE(DFN) ; Get State for Home Address 132 Q $$GET1^DIQ(2,DFN,.115) 133 ZIP(DFN) ; Get Zip code for Home Address 134 Q $$GET1^DIQ(2,DFN,.116) 135 COUNTY(DFN) ; Get County for our Address 136 Q $$GET1^DIQ(2,DFN,.117) 137 COUNTRY(DFN) ; Get Country for our Address 138 ; Unfortunately, it's not stored anywhere in Vista, so the inevitable... 139 Q "USA" 140 RESTEL(DFN) ; Residential Telephone 141 Q $$GET1^DIQ(2,DFN,.131) 142 WORKTEL(DFN) ; Work Telephone 143 Q $$GET1^DIQ(2,DFN,.132) 144 EMAIL(DFN) ; Email Adddress 145 Q $$GET1^DIQ(2,DFN,.133) 146 CELLTEL(DFN) ; Cell Phone 147 Q $$GET1^DIQ(2,DFN,.134) 148 NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name 149 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 150 D NAMECOMP^XLFNAME(.NAME) 151 Q NAME("FAMILY") 152 NOK1GIV(DFN) ; NOK1 Given Name 153 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 154 D NAMECOMP^XLFNAME(.NAME) 155 Q NAME("GIVEN") 156 NOK1MID(DFN) ; NOK1 Middle Name 157 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 158 D NAMECOMP^XLFNAME(.NAME) 159 Q NAME("MIDDLE") 160 NOK1SUF(DFN) ; NOK1 Suffi Name 161 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 162 D NAMECOMP^XLFNAME(.NAME) 163 Q NAME("SUFFIX") 164 NOK1DISP(DFN) ; NOK1 Display Name 165 N NAME S NAME=$$GET1^DIQ(2,DFN,.211) 166 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 167 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 168 NOK1REL(DFN) ; NOK1 Relationship to the patient 169 Q $$GET1^DIQ(2,DFN,.212) 170 NOK1ADD1(DFN) ; NOK1 Address 1 171 Q $$GET1^DIQ(2,DFN,.213) 172 NOK1ADD2(DFN) ; NOK1 Address 2 173 N ADDLN2,ADDLN3 174 S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215) 175 Q:ADDLN3="" ADDLN2 176 Q ADDLN2_", "_ADDLN3 177 NOK1CITY(DFN) ; NOK1 City 178 Q $$GET1^DIQ(2,DFN,.216) 179 NOK1STAT(DFN) ; NOK1 State 180 Q $$GET1^DIQ(2,DFN,.217) 181 NOK1ZIP(DFN) ; NOK1 Zip Code 182 Q $$GET1^DIQ(2,DFN,.218) 183 NOK1HTEL(DFN) ; NOK1 Home Telephone 184 Q $$GET1^DIQ(2,DFN,.219) 185 NOK1WTEL(DFN) ; NOK1 Work Telephone 186 Q $$GET1^DIQ(2,DFN,.21011) 187 NOK1SAME(DFN) ; Is NOK1's Address the same the patient? 188 Q $$GET1^DIQ(2,DFN,.2125) 189 NOK2FAM(DFN) ; NOK2 Family Name 190 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 191 D NAMECOMP^XLFNAME(.NAME) 192 Q NAME("FAMILY") 193 NOK2GIV(DFN) ; NOK2 Given Name 194 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 195 D NAMECOMP^XLFNAME(.NAME) 196 Q NAME("GIVEN") 197 NOK2MID(DFN) ; NOK2 Middle Name 198 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 199 D NAMECOMP^XLFNAME(.NAME) 200 Q NAME("MIDDLE") 201 NOK2SUF(DFN) ; NOK2 Suffi Name 202 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 203 D NAMECOMP^XLFNAME(.NAME) 204 Q NAME("SUFFIX") 205 NOK2DISP(DFN) ; NOK2 Display Name 206 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191) 207 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 208 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 209 NOK2REL(DFN) ; NOK2 Relationship to the patient 210 Q $$GET1^DIQ(2,DFN,.2192) 211 NOK2ADD1(DFN) ; NOK2 Address 1 212 Q $$GET1^DIQ(2,DFN,.2193) 213 NOK2ADD2(DFN) ; NOK2 Address 2 214 N ADDLN2,ADDLN3 215 S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195) 216 Q:ADDLN3="" ADDLN2 217 Q ADDLN2_", "_ADDLN3 218 NOK2CITY(DFN) ; NOK2 City 219 Q $$GET1^DIQ(2,DFN,.2196) 220 NOK2STAT(DFN) ; NOK2 State 221 Q $$GET1^DIQ(2,DFN,.2197) 222 NOK2ZIP(DFN) ; NOK2 Zip Code 223 Q $$GET1^DIQ(2,DFN,.2198) 224 NOK2HTEL(DFN) ; NOK2 Home Telephone 225 Q $$GET1^DIQ(2,DFN,.2199) 226 NOK2WTEL(DFN) ; NOK2 Work Telephone 227 Q $$GET1^DIQ(2,DFN,.211011) 228 NOK2SAME(DFN) ; Is NOK2's Address the same the patient? 229 Q $$GET1^DIQ(2,DFN,.21925) 230 EMERFAM(DFN) ; Emergency Contact (EMER) Family Name 231 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 232 D NAMECOMP^XLFNAME(.NAME) 233 Q NAME("FAMILY") 234 EMERGIV(DFN) ; EMER Given Name 235 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 236 D NAMECOMP^XLFNAME(.NAME) 237 Q NAME("GIVEN") 238 EMERMID(DFN) ; EMER Middle Name 239 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 240 D NAMECOMP^XLFNAME(.NAME) 241 Q NAME("MIDDLE") 242 EMERSUF(DFN) ; EMER Suffi Name 243 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 244 D NAMECOMP^XLFNAME(.NAME) 245 Q NAME("SUFFIX") 246 EMERDISP(DFN) ; EMER Display Name 247 N NAME S NAME=$$GET1^DIQ(2,DFN,.331) 248 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 249 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 250 EMERREL(DFN) ; EMER Relationship to the patient 251 Q $$GET1^DIQ(2,DFN,.331) 252 EMERADD1(DFN) ; EMER Address 1 253 Q $$GET1^DIQ(2,DFN,.333) 254 EMERADD2(DFN) ; EMER Address 2 255 N ADDLN2,ADDLN3 256 S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335) 257 Q:ADDLN3="" ADDLN2 258 Q ADDLN2_", "_ADDLN3 259 EMERCITY(DFN) ; EMER City 260 Q $$GET1^DIQ(2,DFN,.336) 261 EMERSTAT(DFN) ; EMER State 262 Q $$GET1^DIQ(2,DFN,.337) 263 EMERZIP(DFN) ; EMER Zip Code 264 Q $$GET1^DIQ(2,DFN,.338) 265 EMERHTEL(DFN) ; EMER Home Telephone 266 Q $$GET1^DIQ(2,DFN,.339) 267 EMERWTEL(DFN) ; EMER Work Telephone 268 Q $$GET1^DIQ(2,DFN,.33011) 269 EMERSAME(DFN) ; Is EMER's Address the same the NOK? 270 Q $$GET1^DIQ(2,DFN,.3305) -
ccr/trunk/p/CCRDPTT.m
r122 r175 36 36 ; 37 37 W "You have selected patient "_Y,!! 38 D INIT^CCRDPT($P(Y,"^")) 39 ; ZWR PT 40 N I S I=165 F S I=$O(OUT(I)) Q:I="" D 38 N I S I=89 F S I=$O(OUT(I)) Q:I="ALINE" D 41 39 . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" " 42 40 . W "valued at " 43 . W @("$$"_$P(OUT(I,0),"()")_"^"_"CCRDPT"_"()")41 . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"CCRDPT"_"("_$P(Y,"^")_")") 44 42 . W ! 45 43 Q -
ccr/trunk/p/CCRUNIT.m
r173 r175 14 14 W "QUERY^GPLXPATH(T,XPATH,""MINXML"")",!! 15 15 D QUERY^GPLXPATH(T,XPATH,"MINXML") 16 B17 16 W "Executing EXTRACT^CCRMEDS(MINXML,DFN,OUTXML)",! 18 17 W "OUTXML will be ^TMP($J,""OUT"")",! 19 18 N OUTXML S OUTXML=$NA(^TMP($J,"OUT")) 20 D EXTRACT^CCRMEDS( "MINXML",DFN,OUTXML)19 D EXTRACT^CCRMEDS($NA(MINXML),DFN,OUTXML) 21 20 Q -
ccr/trunk/p/GPLACTOR.m
r141 r175 1 1 GPLACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 2 ;;0.3;CCDCCR;nopatch;noreleasedate 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 ;General Public License See attached copy of the License. 2 ;;0.4;CCDCCR;nopatch;noreleasedate 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. 5 19 ; 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. 20 ; PROCESS THE ACTORS SECTION OF THE CCR 10 21 ; 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. 22 ; ===Revision History=== 23 ; 0.1 Initial Writing of Skeleton--GPL 24 ; 0.2 Patient Data Extraction--SMH 25 ; 0.3 Information System Info Extraction--SMH 26 ; 0.4 Patient data rouine refactored; adjustments here--SMH 15 27 ; 16 ;You should have received a copy of the GNU General Public License along17 ;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 ; PROCESS THE ACTORS SECTION OF THE CCR21 ;22 ; ===Revision History===23 ; 0.1 Initial Writing of Skeleton--GPL24 ; 0.2 Patient Data Extraction--SMH25 ; 0.3 Information System Info Extraction--SMH26 ;27 28 EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE 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 29 ; IPXML is the Input Actor Template into which we substitute values 30 ; This is straight XML. Values to be substituted are in @@VAL@@ format. 31 ; ALST is the actor list global generated by ACTLST^GPLCCR and has format: 32 ; ^TMP(7542,1,"ACTORS",0)=Count 33 ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN" 34 ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM" 35 ; AXML is the output arrary, to contain XML. 36 ; 37 N I,J,AMAP,AOID,ATYP,AIEN 38 D CP^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML 39 D REPLACE^GPLXPATH(AXML,"","//Actors") ; DELETE THE INSIDES 40 I DEBUG W "PROCESSING ACTORS ",! 41 F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST 42 . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR 43 . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID 44 . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE 45 . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER 46 . I ATYP="" Q ; NOT A VALID ACTOR 47 . ; 48 . I DEBUG W AOID_" "_ATYP_" "_AIEN,! 49 . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE 50 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP") 51 . . D PATIENT("ATMP",AIEN,AOID,"ATMP2") 52 . ; 53 . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE 54 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP") 55 . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2") 56 . ; 57 . I ATYP="NOK" D ; NOK ACTOR TYPE 58 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP") 59 . . D NOK("ATMP",AIEN,AOID,"ATMP2") 60 . ; 61 . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE 62 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP") 63 . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2") 64 . ; 65 . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE 66 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP") 67 . . D ORG("ATMP",AIEN,AOID,"ATMP2") 68 . ; 69 . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT 70 ; 71 N ACTTMP 72 D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS 73 I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS - 74 . ; STRINGS MARKED AS @@X@@ 75 . W "ACTORS Missing list: ",! 76 . F I=1:1:ACTTMP(0) W ACTTMP(I),! 77 Q 78 ; 78 79 PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR 79 ; 80 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! 81 N AMAP,ZX 82 S AMAP=$NA(^TMP($J,"AMAP")) 83 K @AMAP 84 D INIT^CCRDPT(AIEN) 85 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 86 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT 87 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT 88 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT 89 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT 90 S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT 91 S @AMAP@("ACTORSSN")="" 92 S @AMAP@("ACTORSSNTEXT")="" 93 S @AMAP@("ACTORSSNSOURCEID")="" 94 S ZX=$$SSN^CCRDPT 95 I ZX'="" D ; IF THERE IS A SSN IN THE RECORD 96 . S @AMAP@("ACTORSSN")=ZX 97 . S @AMAP@("ACTORSSNTEXT")="SSN" 98 . S @AMAP@("ACTORSSNSOURCEID")=AOID 99 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT 100 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT 101 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT 102 S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT 103 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT 104 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT 105 S @AMAP@("ACTORRESTEL")="" 106 S @AMAP@("ACTORRESTELTEXT")="" 107 S ZX=$$RESTEL^CCRDPT 108 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 109 . S @AMAP@("ACTORRESTEL")=ZX 110 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" 111 S @AMAP@("ACTORWORKTEL")="" 112 S @AMAP@("ACTORWORKTELTEXT")="" 113 S ZX=$$WORKTEL^CCRDPT 114 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 115 . S @AMAP@("ACTORWORKTEL")=ZX 116 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" 117 S @AMAP@("ACTORCELLTEL")="" 118 S @AMAP@("ACTORCELLTELTEXT")="" 119 S ZX=$$CELLTEL^CCRDPT 120 I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD 121 . S @AMAP@("ACTORCELLTEL")=ZX 122 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" 123 S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT 124 S @AMAP@("ACTORADDRESSSOURCEID")=AOID 125 S @AMAP@("ACTORIEN")=AIEN 126 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX 127 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE 128 D DESTROY^CCRDPT 129 D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 130 Q 131 ; 80 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,! 81 N AMAP,ZX 82 S AMAP=$NA(^TMP($J,"AMAP")) 83 K @AMAP 84 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID 85 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN) 86 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN) 87 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN) 88 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN) 89 S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN) 90 S @AMAP@("ACTORSSN")="" 91 S @AMAP@("ACTORSSNTEXT")="" 92 S @AMAP@("ACTORSSNSOURCEID")="" 93 S ZX=$$SSN^CCRDPT(AIEN) 94 I ZX'="" D ; IF THERE IS A SSN IN THE RECORD 95 . S @AMAP@("ACTORSSN")=ZX 96 . S @AMAP@("ACTORSSNTEXT")="SSN" 97 . S @AMAP@("ACTORSSNSOURCEID")=AOID 98 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN) 99 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN) 100 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN) 101 S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN) 102 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN) 103 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN) 104 S @AMAP@("ACTORRESTEL")="" 105 S @AMAP@("ACTORRESTELTEXT")="" 106 S ZX=$$RESTEL^CCRDPT(AIEN) 107 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 108 . S @AMAP@("ACTORRESTEL")=ZX 109 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone" 110 S @AMAP@("ACTORWORKTEL")="" 111 S @AMAP@("ACTORWORKTELTEXT")="" 112 S ZX=$$WORKTEL^CCRDPT(AIEN) 113 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD 114 . S @AMAP@("ACTORWORKTEL")=ZX 115 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone" 116 S @AMAP@("ACTORCELLTEL")="" 117 S @AMAP@("ACTORCELLTELTEXT")="" 118 S ZX=$$CELLTEL^CCRDPT(AIEN) 119 I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD 120 . S @AMAP@("ACTORCELLTEL")=ZX 121 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone" 122 S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN) 123 S @AMAP@("ACTORADDRESSSOURCEID")=AOID 124 S @AMAP@("ACTORIEN")=AIEN 125 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX 126 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE 127 D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE 128 Q 129 ; 132 130 SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR 133 131 ;
Note:
See TracChangeset
for help on using the changeset viewer.
