- Location:
- /ccr/trunk/p
- Files:
-
- 1 added
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
/ccr/trunk/p/CCRDPT.m
r20 r30 4 4 ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and 5 5 ; DESTROY to clean-up. 6 7 ; The first line of every routine tests if the global exists. 8 9 ; CCRDPT 83 lines CCRCCD/SMH - Routines to Extract Patient Data for 10 ; INIT 9 lines Copy DFN global to a local variable 11 ; DESTROY 6 lines Kill local variable 12 ; FAMILY 6 lines Family Name 13 ; GIVEN 6 lines Given Name 14 ; MIDDLE 6 lines Middle Name 15 ; SUFFIX 6 lines Suffix Name 16 ; DISPNAME 5 lines Display Name 17 ; DOB 6 lines Date of Birth 18 ; GENDER 4 lines Get Gender 19 ; SSN 4 lines Get SSN for ID 20 ; ADDRTYPE 4 lines Get Home Address 21 ; ADDR1 4 lines Get Home Address line 1 22 ; ADDR2 5 lines Get Home Address line 2 23 ; CITY 4 lines Get City for Home Address 24 ; STATE 11 lines Get State for Home Address 25 ; ZIP 4 lines Get Zip code for Home Address 26 ; COUNTY 4 lines Get County for our Address 27 ; COUNTRY 4 lines Get Country for our Address 28 ; RESTEL 4 lines Residential Telephone 29 ; WORKTEL 4 lines Work Telephone 30 ; EMAIL 4 lines Email Adddress 31 ; CELLTEL 4 lines Cell Phone 32 ; NOK1FAM 6 lines Next of Kin 1 (NOK1) Family Name 33 ; NOK1GIV 6 lines NOK1 Given Name 34 ; NOK1MID 6 lines NOK1 Middle Name 35 ; NOK1SUF 6 lines NOK1 Suffi Name 36 ; NOK1DISP 5 lines NOK1 Display Name 37 ; NOK1REL 4 lines NOK1 Relationship to the patient 38 ; NOK1ADD1 4 lines NOK1 Address 1 39 ; NOK1ADD2 5 lines NOK1 Address 2 40 ; NOK1CITY 4 lines NOK1 City 41 ; NOK1STAT 5 lines NOK1 State 42 ; NOK1ZIP 4 lines NOK1 Zip Code 43 ; NOK1HTEL; 4 lines NOK1 Home Telephone 44 ; NOK1WTEL; 4 lines NOK1 Work Telephone 45 ; NOK1SAME; 4 lines Is NOK1's Address the same the patient? 46 ; NOK2FAM 6 lines NOK2 Family Name 47 ; NOK2GIV 6 lines NOK2 Given Name 48 ; NOK2MID 6 lines NOK2 Middle Name 49 ; NOK2SUF 5 lines NOK2 Suffi Name 50 ; NOK2DISP 5 lines NOK2 Display Name 51 ; NOK2REL 4 lines NOK2 Relationship to the patient 52 ; NOK2ADD1 4 lines NOK2 Address 1 53 ; NOK2ADD2 5 lines NOK2 Address 2 54 ; NOK2CITY 4 lines NOK2 City 55 ; NOK2STAT 5 lines NOK2 State 56 ; NOK2ZIP 4 lines NOK2 Zip Code 57 ; NOK2HTEL; 4 lines NOK2 Home Telephone 58 ; NOK2WTEL; 4 lines NOK2 Work Telephone 59 ; NOK2SAME; 4 lines Is NOK2's Address the same the patient? 60 ; EMERFAM 6 lines Emergency Contact (EMER) Family Name 61 ; EMERGIV 6 lines EMER Given Name 62 ; EMERMID 6 lines EMER Middle Name 63 ; EMERSUF 5 lines EMER Suffi Name 64 ; EMERDISP 5 lines EMER Display Name 65 ; EMERREL 4 lines EMER Relationship to the patient 66 ; EMERADD1 4 lines EMER Address 1 67 ; EMERADD2 5 lines EMER Address 2 68 ; EMERCITY 4 lines EMER City 69 ; EMERSTAT 5 lines EMER State 70 ; EMERZIP 4 lines EMER Zip Code 71 ; EMERHTEL; 4 lines EMER Home Telephone 72 ; EMERWTEL; 4 lines EMER Work Telephone 73 ; EMERSAME; 4 lines Is EMER's Address the same the NOK? 6 74 7 75 W "No Entry at top!" Q … … 99 167 FAMILY() ; Family Name; PUBLIC; Extrinsic 100 168 ; PREREQ: PT Defined 169 Q:$G(PT(0))="" "" 101 170 N NAME S NAME=$P(PT(0),"^",1) 102 171 D NAMECOMP^XLFNAME(.NAME) … … 105 174 GIVEN() ; Given Name; PUBLIC; Extrinsic 106 175 ; PREREQ: PT Defined 176 Q:$G(PT(0))="" "" 107 177 N NAME S NAME=$P(PT(0),"^",1) 108 178 D NAMECOMP^XLFNAME(.NAME) … … 111 181 MIDDLE() ; Middle Name; PUBLIC; Extrinsic 112 182 ; PREREQ: PT Defined 183 Q:$G(PT(0))="" "" 113 184 N NAME S NAME=$P(PT(0),"^",1) 114 185 D NAMECOMP^XLFNAME(.NAME) … … 117 188 SUFFIX() ; Suffi Name; PUBLIC; Extrinsic 118 189 ; PREREQ: PT Defined 190 Q:$G(PT(0))="" "" 119 191 N NAME S NAME=$P(PT(0),"^",1) 120 192 D NAMECOMP^XLFNAME(.NAME) … … 123 195 DISPNAME() ; Display Name; PUBLIC; Extrinsic 124 196 ; PREREQ: PT Defined 197 Q:$G(PT(0))="" "" 125 198 N NAME S NAME=$P(PT(0),"^",1) 126 199 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") … … 128 201 DOB() ; Date of Birth; PUBLIC; Extrinsic 129 202 ; PREREQ: PT Defined 203 Q:$G(PT(0))="" "" 130 204 N DOB S DOB=$P(PT(0),"^",3) 131 205 ; Date in FM Date Format. Convert to UTC/ISO 8601. … … 134 208 GENDER() ; Get Gender; PUBLIC; Extrinsic 135 209 ; PREREQ: PT Defined 210 Q:$G(PT(0))="" "" 136 211 Q $P(PT(0),"^",2) 137 212 ; 138 213 SSN() ; Get SSN for ID; PUBLIC; Extrinsic 139 214 ; PREREQ: PT Defined 215 Q:$G(PT(0))="" "" 140 216 Q $P(PT(0),"^",9) 141 217 ; 142 ADDRTYPE( ADDR) ; Get Home Address; PUBLIC; Extrinsic218 ADDRTYPE() ; Get Home Address; PUBLIC; Extrinsic 143 219 ; Vista only stores a home address for the patient. 220 Q:$G(PT(0))="" "" 144 221 Q "Home" 145 222 ; 146 223 ADDR1() ; Get Home Address line 1; PUBLIC; Extrinsic 147 224 ; PREREQ: PT Defined 225 Q:$G(PT(.11))="" "" 148 226 Q $P(PT(.11),"^",1) 149 227 ; … … 151 229 ; PREREQ: PT Defined 152 230 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise 231 Q:$G(PT(.11))="" "" 232 ; If the thrid address is empty, just return the 2nd. 233 ; If the 2nd is empty, we don't lose, b/c it will return "" 234 ; This is so that we won't produce a comma if there is no 3rd addr. 235 Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2) 153 236 Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3) 154 237 ; 155 238 CITY() ; Get City for Home Address; PUBLIC; Extrinsic 156 239 ; PREREQ: PT Defined 240 Q:$G(PT(.11))="" "" 157 241 Q $P(PT(.11),"^",4) 158 242 ; 159 243 STATE() ; Get State for Home Address; PUBLIC; Extrinsic 160 244 ; PREREQ: PT Defined 245 Q:$G(PT(.11))="" "" 161 246 ; State is stored as a pointer 162 N STATENUM =$P(PT(.11)"^",5)247 N STATENUM S STATENUM=$P(PT(.11),"^",5) 163 248 ; 164 249 ; State File Global is below … … 166 251 ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2) 167 252 ; ==>US STATE OR POSSESSION [6S] ^ 253 Q:STATENUM="" "" ; To prevent global undefined below if no state 168 254 Q $P(^DIC(5,STATENUM,0),"^",1) 169 255 ; 170 ZIP() ; Get Zip code for Home Address 171 ; PREREQ: PT Defined 256 ZIP() ; Get Zip code for Home Address; PUBLIC; Extrinsic 257 ; PREREQ: PT Defined 258 Q:$G(PT(.11))="" "" 172 259 Q $P(PT(.11),"^",6) 173 260 ; 174 COUNTY() ; Get County for our Address 175 ; PREREQ: PT Defined 261 COUNTY() ; Get County for our Address; PUBLIC; Extrinsic 262 ; PREREQ: PT Defined 263 Q:$G(PT(.11))="" "" 176 264 Q $P(PT(.11),"^",7) 177 265 ; 266 COUNTRY() ; Get Country for our Address; PUBLIC; Extrinsic 267 ; Unfortunately, I can't find where that is stored, so the inevitable... 268 Q:$G(PT(.11))="" "" 269 Q "USA" 270 ; 271 RESTEL() ; Residential Telephone; PUBLIC; Extrinsic 272 ; PREREQ: PT Defined 273 Q:$G(PT(.13))="" "" 274 Q $P(PT(.13),"^",1) 275 ; 276 WORKTEL() ; Work Telephone; PUBLIC; Extrinsic 277 ; PREREQ: PT Defined 278 Q:$G(PT(.13))="" "" 279 Q $P(PT(.13),"^",2) 280 ; 281 EMAIL() ; Email Adddress; PUBLIC; Extrinsic 282 ; PREREQ: PT Defined 283 Q:$G(PT(.13))="" "" 284 Q $P(PT(.13),"^",3) 285 ; 286 CELLTEL() ; Cell Phone; PUBLIC; Extrinsic 287 ; PREREQ: PT Defined 288 Q:$G(PT(.13))="" "" 289 Q $P(PT(.13),"^",4) 290 ; 291 NOK1FAM() ; Next of Kin 1 (NOK1) Family Name; PUBLIC; Extrinsic 292 ; PREREQ: PT Defined 293 Q:$G(PT(.21))="" "" 294 N NAME S NAME=$P(PT(.21),"^",1) 295 D NAMECOMP^XLFNAME(.NAME) 296 Q NAME("FAMILY") 297 ; 298 NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic 299 ; PREREQ: PT Defined 300 Q:$G(PT(.21))="" "" 301 N NAME S NAME=$P(PT(.21),"^",1) 302 D NAMECOMP^XLFNAME(.NAME) 303 Q NAME("GIVEN") 304 ; 305 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic 306 ; PREREQ: PT Defined 307 Q:$G(PT(.21))="" "" 308 N NAME S NAME=$P(PT(.21),"^",1) 309 D NAMECOMP^XLFNAME(.NAME) 310 Q NAME("MIDDLE") 311 ; 312 NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic 313 ; PREREQ: PT Defined 314 Q:$G(PT(.21))="" "" 315 N NAME S NAME=$P(PT(.21),"^",1) 316 D NAMECOMP^XLFNAME(.NAME) 317 Q NAME("SUFFIX") 318 ; 319 NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic 320 ; PREREQ: PT Defined 321 Q:$G(PT(.21))="" "" 322 N NAME S NAME=$P(PT(.21),"^",1) 323 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 324 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 325 NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic 326 ; PREREQ: PT Defined 327 Q:$G(PT(.21))="" "" 328 Q $P(PT(.21),"^",2) 329 ; 330 NOK1ADD1() ; NOK1 Address 1; PUBLIC; Extrinsic 331 ; PREREQ: PT Defined 332 Q:$G(PT(.21))="" "" 333 Q $P(PT(.21),"^",3) 334 ; 335 NOK1ADD2() ; NOK1 Address 2; PUBLIC; Extrinsic 336 ; PREREQ: PT Defined 337 ; As before, CCR only allows two fileds for the address, so we have to compromise 338 Q:$G(PT(.21))="" "" 339 ; If the thrid address is empty, just return the 2nd. 340 ; If the 2nd is empty, we don't lose, b/c it will return "" 341 ; This is so that we won't produce a comma if there is no 3rd addr. 342 Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4) 343 Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5) 344 ; 345 NOK1CITY() ; NOK1 City; PUBLIC; Extrinsic 346 ; PREREQ: PT Defined 347 Q:$G(PT(.21))="" "" 348 Q $P(PT(.21),"^",6) 349 ; 350 NOK1STAT() ; NOK1 State; PUBLIC; Extrinsic 351 ; PREREQ: PT Defined 352 Q:$G(PT(.21))="" "" 353 N STATENUM S STATENUM=$P(PT(.21),"^",7) 354 Q:STATENUM="" "" 355 Q $P(^DIC(5,STATENUM,0),"^",1) 356 ; 357 NOK1ZIP() ; NOK1 Zip Code; PUBLIC; Extrinsic 358 ; PREREQ: PT Defined 359 Q:$G(PT(.21))="" "" 360 Q $P(PT(.21),"^",8) 361 ; 362 NOK1HTEL() ; NOK1 Home Telephone; PUBLIC; Extrinsic 363 ; PREREQ: PT Defined 364 Q:$G(PT(.21))="" "" 365 Q $P(PT(.21),"^",9) 366 ; 367 NOK1WTEL() ; NOK1 Work Telephone; PUBLIC; Extrinsic 368 ; PREREQ: PT Defined 369 Q:$G(PT(.21))="" "" 370 Q $P(PT(.21),"^",11) 371 ; 372 NOK1SAME() ; Is NOK1's Address the same the patient?; PUBLIC; Extrinsic 373 ; PREREQ: PT Defined 374 Q:$G(PT(.21))="" "" 375 Q $P(PT(.21),"^",10) 376 ; 377 NOK2FAM() ; NOK2 Family Name; PUBLIC; Extrinsic 378 ; PREREQ: PT Defined 379 Q:$G(PT(.211))="" "" 380 N NAME S NAME=$P(PT(.211),"^",1) 381 D NAMECOMP^XLFNAME(.NAME) 382 Q NAME("FAMILY") 383 ; 384 NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined 385 Q:$G(PT(.211))="" "" 386 N NAME S NAME=$P(PT(.211),"^",1) 387 D NAMECOMP^XLFNAME(.NAME) 388 Q NAME("GIVEN") 389 ; 390 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic 391 ; PREREQ: PT Defined 392 Q:$G(PT(.211))="" "" 393 N NAME S NAME=$P(PT(.211),"^",1) 394 D NAMECOMP^XLFNAME(.NAME) 395 Q NAME("MIDDLE") 396 ; 397 NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic 398 ; PREREQ: PT Defined 399 Q:$G(PT(.211))="" "" 400 N NAME S NAME=$P(PT(.211),"^",1) 401 D NAMECOMP^XLFNAME(.NAME) 402 Q NAME("SUFFIX") 403 NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic 404 ; PREREQ: PT Defined 405 Q:$G(PT(.211))="" "" 406 N NAME S NAME=$P(PT(.211),"^",1) 407 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 408 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 409 NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic 410 ; PREREQ: PT Defined 411 Q:$G(PT(.211))="" "" 412 Q $P(PT(.211),"^",2) 413 ; 414 NOK2ADD1() ; NOK2 Address 1; PUBLIC; Extrinsic 415 ; PREREQ: PT Defined 416 Q:$G(PT(.211))="" "" 417 Q $P(PT(.211),"^",3) 418 ; 419 NOK2ADD2() ; NOK2 Address 2; PUBLIC; Extrinsic 420 ; PREREQ: PT Defined 421 ; As before, CCR only allows two fileds for the address, so we have to compromise 422 Q:$G(PT(.211))="" "" 423 ; If the thrid address is empty, just return the 2nd. 424 ; If the 2nd is empty, we don't lose, b/c it will return "" 425 ; This is so that we won't produce a comma if there is no 3rd addr. 426 Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4) 427 Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5) 428 ; 429 NOK2CITY() ; NOK2 City; PUBLIC; Extrinsic 430 ; PREREQ: PT Defined 431 Q:$G(PT(.211))="" "" 432 Q $P(PT(.211),"^",6) 433 ; 434 NOK2STAT() ; NOK2 State; PUBLIC; Extrinsic 435 ; PREREQ: PT Defined 436 Q:$G(PT(.211))="" "" 437 N STATENUM S STATENUM=$P(PT(.211),"^",7) 438 Q:STATENUM="" "" ; To prevent global undefined below if no state 439 Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above 440 ; 441 NOK2ZIP() ; NOK2 Zip Code; PUBLIC; Extrinsic 442 ; PREREQ: PT Defined 443 Q:$G(PT(.211))="" "" 444 Q $P(PT(.211),"^",8) 445 ; 446 NOK2HTEL() ; NOK2 Home Telephone; PUBLIC; Extrinsic 447 ; PREREQ: PT Defined 448 Q:$G(PT(.211))="" "" 449 Q $P(PT(.211),"^",9) 450 ; 451 NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic 452 ; PREREQ: PT Defined 453 Q:$G(PT(.211))="" "" 454 Q $P(PT(.211),"^",11) 455 ; 456 NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic 457 ; PREREQ: PT Defined 458 Q:$G(PT(.211))="" "" 459 Q $P(PT(.211),"^",10) 460 ; 461 EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic 462 ; PREREQ: PT Defined 463 Q:$G(PT(.33))="" "" 464 N NAME S NAME=$P(PT(.33),"^",1) 465 D NAMECOMP^XLFNAME(.NAME) 466 Q NAME("FAMILY") 467 ; 468 EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic 469 ; PREREQ: PT Defined 470 Q:$G(PT(.33))="" "" 471 N NAME S NAME=$P(PT(.33),"^",1) 472 D NAMECOMP^XLFNAME(.NAME) 473 Q NAME("GIVEN") 474 ; 475 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic 476 ; PREREQ: PT Defined 477 Q:$G(PT(.33))="" "" 478 N NAME S NAME=$P(PT(.33),"^",1) 479 D NAMECOMP^XLFNAME(.NAME) 480 Q NAME("MIDDLE") 481 ; 482 EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic 483 ; PREREQ: PT Defined 484 Q:$G(PT(.33))="" "" 485 N NAME S NAME=$P(PT(.33),"^",1) 486 D NAMECOMP^XLFNAME(.NAME) 487 Q NAME("SUFFIX") 488 EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic 489 ; PREREQ: PT Defined 490 Q:$G(PT(.33))="" "" 491 N NAME S NAME=$P(PT(.33),"^",1) 492 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 493 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 494 EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic 495 ; PREREQ: PT Defined 496 Q:$G(PT(.33))="" "" 497 Q $P(PT(.33),"^",2) 498 ; 499 EMERADD1() ; EMER Address 1; PUBLIC; Extrinsic 500 ; PREREQ: PT Defined 501 Q:$G(PT(.33))="" "" 502 Q $P(PT(.33),"^",3) 503 ; 504 EMERADD2() ; EMER Address 2; PUBLIC; Extrinsic 505 ; PREREQ: PT Defined 506 ; As before, CCR only allows two fileds for the address, so we have to compromise 507 Q:$G(PT(.33))="" "" 508 ; If the thrid address is empty, just return the 2nd. 509 ; If the 2nd is empty, we don't lose, b/c it will return "" 510 ; This is so that we won't produce a comma if there is no 3rd addr. 511 Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4) 512 Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5) 513 ; 514 EMERCITY() ; EMER City; PUBLIC; Extrinsic 515 ; PREREQ: PT Defined 516 Q:$G(PT(.33))="" "" 517 Q $P(PT(.33),"^",6) 518 ; 519 EMERSTAT() ; EMER State; PUBLIC; Extrinsic 520 ; PREREQ: PT Defined 521 Q:$G(PT(.33))="" "" 522 N STATENUM S STATENUM=$P(PT(.33),"^",7) 523 Q:STATENUM="" "" ; To prevent global undefined below if no state 524 Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above 525 ; 526 EMERZIP() ; EMER Zip Code; PUBLIC; Extrinsic 527 ; PREREQ: PT Defined 528 Q:$G(PT(.33))="" "" 529 Q $P(PT(.33),"^",8) 530 ; 531 EMERHTEL() ; EMER Home Telephone; PUBLIC; Extrinsic 532 ; PREREQ: PT Defined 533 Q:$G(PT(.33))="" "" 534 Q $P(PT(.33),"^",9) 535 ; 536 EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic 537 ; PREREQ: PT Defined 538 Q:$G(PT(.33))="" "" 539 Q $P(PT(.33),"^",11) 540 ; 541 EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic 542 ; PREREQ: PT Defined 543 Q:$G(PT(.33))="" "" 544 Q $P(PT(.33),"^",10) 545 ; -
/ccr/trunk/p/GPLCCR.m
r20 r30 7 7 ; Select a patient for real. 8 8 S DIC=2,DIC(0)="AEMQ" D ^DIC 9 I Y<1 Q ; EXIT 9 10 S DFN=$P(Y,U,1) ; SET THE PATIENT 10 11 N CCRGLO … … 12 13 S OARY=$NA(^TMP($J,DFN,"CCR",1)) 13 14 S ONAM="PAT_"_DFN_"_CCR_V1.xml" 14 S ODIR="/home/ wvehr1/EHR/CCR"15 S ODIR="/home/glilly/CCROUT" 15 16 D OUTPUT^GPLXPATH(OARY,ONAM,ODIR) 16 17 Q … … 20 21 S TGLOBAL=$NA(^TMP($J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE 21 22 S CCRGLO=$NA(^TMP($J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR 23 S ACTGLO=$NA(^TMP($J,DFN,"ACTORS")); GLOBAL FOR ALL ACTORS IN CCR 22 24 ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC 23 25 S CCRGRTN=$NA(^TMP($J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL OF CCR … … 26 28 ; 27 29 ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM THE CCR GLOBAL 28 ; THESE WILL BE POPULATED WITHCALLS TO THE XPATH PROCESSING ROUTINES30 ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH PROCESSING ROUTINES 29 31 D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") 30 32 D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") 31 33 D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") 32 F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!34 I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! 33 35 ; 36 D CCRHDR(CCRGLO,DFN) ; MAP HEADER VARIABLES 34 37 S CCRXTAB="^TMP($J,""CCRSTEP"")" ; GLOBAL TO STORE CCR PROCESSING STEPS 35 38 D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS … … 48 51 . X CALL 49 52 . ; NOW INSERT THE RESULTS IN THE CCR BUFFER 50 . ;D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")53 . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body") 51 54 . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),! 52 . D QOPEN^GPLXPATH("CCRBLD",CCRGLO,"//ContinuityOfCareRecord/Body") 53 . D QUEUE^GPLXPATH("CCRBLD",OXML,1,@OXML@(0)) 54 . D QCLOSE^GPLXPATH("CCRBLD",CCRGLO,"//ContinuityOfCareRecord/Body") 55 . I DEBUG W "GOING TO BUILD CCR",! 56 . N CCRTMP 57 . D BUILD^GPLXPATH("CCRBLD","CCRTMP") 58 . I DEBUG F GPLI=1:1:CCRTMP(0) W CCRTMP(GPLI),! 59 . D CP^GPLXPATH("CCRTMP",CCRGLO) 55 . D ACTLST^GPLCCR(CCRGLO,ACTGLO) 60 56 Q 61 57 ; … … 67 63 Q 68 64 ; 65 CCRHDR(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT 66 N VMAP S VMAP=$NA(^TMP($J,DFN,"HEADER")) 67 ; K @VMAP 68 S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN 69 S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ??? 70 S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED A BETTER WAY 71 S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN ; FOR TEST PURPOSES, 72 ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT 73 N CTMP 74 D MAP^GPLXPATH(CXML,VMAP,"CTMP") 75 D CP^GPLXPATH("CTMP",CXML) 76 Q 77 ; 78 ACTLST(AXML,ACTRTN) ; RETURN THE ACTOR LIST FOR THE XML IN AXML 79 ; AXML AND ACTRTN ARE PASSED BY NAME 80 N I,J,K 81 K @ACTRTN ; CLEAR RETURN ARRAY 82 F I=1:1:@AXML@(0) D ; SCAN ALL LINES 83 . I @AXML@(I)?.E1"<ActorID>".E D ; THERE IS AN ACTOR ON THIS LINE 84 . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1) 85 . . W "<ActorID>=>",J,! 86 . . S K(J)="" ; HASHING ACTOR TO GET RID OF MULTIPLES 87 S I="" ; GOING TO $O THROUGH THE HASH 88 F J=0:0 D Q:$O(K(I))="" 89 . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS 90 . D PUSH^GPLXPATH(ACTRTN,I) ; ADD THE ACTOR TO THE RETURN ARRAY 91 Q 92 ; 69 93 TEST ; RUN ALL THE TEST CASES 70 N ZTMP 71 D ZLOAD^GPLUNIT("ZTMP","GPLCCR") 72 D ZTEST^GPLUNIT(.ZTMP,"ALL") 73 W ! 74 ; W "THE TESTS!",! 75 ; ZWR ZTMP 94 ;D TESTALL^GPLUNIT("GPLCCR") 95 D ZTEST^GPLCCR("PROBLEMS") 96 W "TESTING RETURNED FROM PROBLMES",! 97 D ZTEST^GPLCCR("CCR") 76 98 Q 77 99 ; … … 89 111 ; 90 112 ;;><TEST> 91 ;;>< INIT>113 ;;><PROBLEMS> 92 114 ;;>>>K GPL S GPL="" 115 ;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS") 116 ;;>>?@GPL@(@GPL@(0))="</Problems>" 117 ;;><CCR> 118 ;;>>>K GPL S GPL="" 119 ;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR") 120 ;;>>?@GPL@(@GPL@(0))="</ContinutiyOfCareRecord>" 121 ;;><ACTLST> 122 ;;>>>N TCCR 123 ;;>>>D CCRRPC^GPLCCR(.TCCR,"2","CCR") 124 ;;>>>D ACTLST^GPLCCR("TCCR","ACTTEST") 93 125 ;;></TEST> -
/ccr/trunk/p/GPLCCR0.m
r20 r30 47 47 ;<TEMPLATE> 48 48 ;;<?xml version="1.0" encoding="UTF-8"?> 49 ;;<?xml-stylesheet type="text/xsl" href="ccr_20060420.xsl"?> 49 50 ;;<ContinuityOfCareRecord xmlns="urn:astm-org:CCR"> 50 51 ;;<CCRDocumentObjectID>871bd605-e8f8-4b80-9918-4b03f781129e</CCRDocumentObjectID> … … 91 92 ;;<Code> 92 93 ;;<Value>@@PROBLEMCODEVALUE@@</Value> 93 ;;<CodingSystem> @@PROBLEMCODINGSYSTEM@@ICD9CM</CodingSystem>94 ;;<Version>@@PROBLEMCODINGVERSION@@ 2007</Version>94 ;;<CodingSystem>ICD9CM</CodingSystem> 95 ;;<Version>@@PROBLEMCODINGVERSION@@</Version> 95 96 ;;</Code> 96 97 ;;</Description> -
/ccr/trunk/p/GPLPROBS.m
r20 r30 15 15 D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC 16 16 I '$D(RPCRSLT(0)) W "ERROR CALLING LIST^ORQQPL3 ",! Q 17 I DEBUGZWR RPCRSLT17 ZWR RPCRSLT 18 18 S TVMAP=$NA(^TMP($J,"PROBVALS")) 19 19 S TARYTMP=$NA(^TMP($J,"PROBARYTMP")) -
/ccr/trunk/p/GPLUNIT.m
r20 r30 17 17 S ZARY(CNT)=TST ; put the test in the array 18 18 I $D(ZARY(BAT)) D ; NOT THE FIRST TEST IN BATTERY 19 . N II ; TEMP FOR ENDING TEST IN BATTERY19 . N II,TN ; TEMP FOR ENDING TEST IN BATTERY 20 20 . S II=$P(ZARY(BAT),"^",2) 21 21 . S $P(ZARY(BAT),"^",2)=II+1 … … 23 23 . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY 24 24 . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX 25 . ; S TN=$NA(ZARY("TESTS")) 26 . ; D PUSH^GPLXPATH(TN,BAT) 25 27 S ZARY(0)=CNT ; update the array counter 26 28 Q … … 50 52 ; 51 53 ZTEST(ZARY,WHICH) ; try out the tests using a passed array ZTEST 52 N I,ZX,ZR,ZP 53 S DEBUG=0 54 I '$D(ZARY(WHICH)) D ; TEST SECTION DOESN'T EXIST 55 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! 56 . Q ; EXIT 57 N FIRST,LAST 58 S FIRST=$P(ZARY(WHICH),"^",1) 59 S LAST=$P(ZARY(WHICH),"^",2) 60 F I=FIRST:1:LAST D 61 . I ZARY(I)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT 62 . . S ZP=$E(ZARY(I),2,$L(ZARY(I))) 63 . . ; W ZP,! 64 . . S ZX=ZP 65 . . W "RUNNING: "_ZP 66 . . X ZX 67 . . W "..SUCCESS: ",WHICH,! 68 . I ZARY(I)?1"?"1.E D ; THIS IS A TEST 69 . . S ZP=$E(ZARY(I),2,$L(ZARY(I))) 70 . . S ZX="S ZR="_ZP 71 . . W "TRYING: "_ZP 72 . . X ZX 73 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! 74 . . I '$D(TPASSED) D ; NOT INITIALIZED YET 75 . . . S TPASSED=0 S TFAILED=0 76 . . I ZR S TPASSED=TPASSED+1 77 . . I 'ZR S TFAILED=TFAILED+1 78 Q 79 ; 54 N I,ZX,ZR,ZP 55 S DEBUG=0 56 ; I WHICH="ALL" D Q ; RUN ALL THE TESTS 57 ; . W "DOING ALL",! 58 ; . N J,NT 59 ; . S NT=$NA(ZARY("TESTS")) 60 ; . W NT,@NT@(0),! 61 ; . F J=1:1:@NT@(0) D ; 62 ; . . W @NT@(J),! 63 ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J)) 64 I '$D(ZARY(WHICH)) D ; TEST SECTION DOESN'T EXIST 65 . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,! 66 . Q ; EXIT 67 N FIRST,LAST 68 S FIRST=$P(ZARY(WHICH),"^",1) 69 S LAST=$P(ZARY(WHICH),"^",2) 70 F I=FIRST:1:LAST D 71 . I ZARY(I)?1">"1.E D ; NOT A TEST, JUST RUN THE STATEMENT 72 . . S ZP=$E(ZARY(I),2,$L(ZARY(I))) 73 . . ; W ZP,! 74 . . S ZX=ZP 75 . . W "RUNNING: "_ZP 76 . . X ZX 77 . . W "..SUCCESS: ",WHICH,! 78 . I ZARY(I)?1"?"1.E D ; THIS IS A TEST 79 . . S ZP=$E(ZARY(I),2,$L(ZARY(I))) 80 . . S ZX="S ZR="_ZP 81 . . W "TRYING: "_ZP 82 . . X ZX 83 . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),! 84 . . I '$D(TPASSED) D ; NOT INITIALIZED YET 85 . . . S TPASSED=0 S TFAILED=0 86 . . I ZR S TPASSED=TPASSED+1 87 . . I 'ZR S TFAILED=TFAILED+1 88 Q 89 ; 80 90 TEST ; RUN ALL THE TEST CASES 81 91 N ZTMP … … 89 99 Q 90 100 ; 101 GTSTS(GTZARY,RTN) ; return an array of test names 102 N I,J S I="" S I=$O(GTZARY("TESTS",I)) 103 F J=0:0 Q:I="" D 104 . D PUSH^GPLXPATH(RTN,I) 105 . S I=$O(GTZARY("TESTS",I)) 106 Q 107 ; 108 TESTALL(RNM) ; RUN ALL THE TESTS 109 N I,J,TZTMP,TSTS,TOTP,TOTF 110 S TOTP=0 S TOTF=0 111 D ZLOAD^GPLUNIT("TZTMP",RNM) 112 D GTSTS(.TZTMP,"TSTS") 113 F I=1:1:TSTS(0) D ; 114 . S TPASSED=0 S TFAILED=0 115 . D ZTEST^GPLUNIT(.TZTMP,TSTS(I)) 116 . S TOTP=TOTP+TPASSED 117 . S TOTF=TOTF+TFAILED 118 . S $P(TSTS(I),"^",2)=TPASSED 119 . S $P(TSTS(I),"^",3)=TFAILED 120 F I=1:1:TSTS(0) D ; 121 . W "TEST=> ",$P(TSTS(I),"^",1) 122 . W " PASSED=>",$P(TSTS(I),"^",2) 123 . W " FAILED=>",$P(TSTS(I),"^",3),! 124 W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,! 125 Q 126 ; 91 127 TLIST(ZARY) ; LIST ALL THE TESTS 92 128 ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES -
/ccr/trunk/p/GPLXPATH.m
r20 r30 189 189 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! 190 190 . Q 191 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INITIALIZE 191 192 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY 192 193 D BUILD("CPINSTR",CPDEST) … … 238 239 ; XML AT THE END OF THE XPATH POINT 239 240 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE 240 ;N INSBLD,INSTMP241 N INSBLD,INSTMP 241 242 I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! 242 243 I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! 243 I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY 244 . W "DOING A BAD COPY",! 245 . D CP^GPLXPATH(INSNEW,INXML) ; JUST COPY INTO THE OUTPUT 244 I '$D(@INSXML@(0)) D Q ; INSERT INTO AN EMPTY ARRAY 245 . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT 246 246 I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY 247 . W "GOT HERE",!248 247 . I $D(INSXPATH) D ; XPATH PROVIDED 249 248 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE … … 256 255 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 257 256 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH 258 . D BUILD("INSBLD", INSTMP) ; PUT RESULTS IN INDEST259 . D CP^GPLXPATH( INSTMP,INSXML) ; COPY BUFFER TO SOURCE257 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST 258 . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE 260 259 Q 261 260 ; … … 334 333 Q 335 334 ; 336 TEST ; RUN ALL THE TEST CASES 337 N ZTMP 338 D ZLOAD^GPLUNIT("ZTMP","GPLXPATH") 339 D ZTEST^GPLUNIT(.ZTMP,"ALL") 340 W "PASSED: ",TPASSED,! 341 W "FAILED: ",TFAILED,! 342 W ! 343 ; W "THE TESTS!",! 344 ; ZWR ZTMP 335 TEST ; Run all the test cases 336 D TESTALL^GPLUNIT("GPLXPATH") 345 337 Q 346 338 ; 339 OLDTEST ; RUN ALL THE TEST CASES 340 N ZTMP 341 D ZLOAD^GPLUNIT("ZTMP","GPLXPATH") 342 D ZTEST^GPLUNIT(.ZTMP,"ALL") 343 W "PASSED: ",TPASSED,! 344 W "FAILED: ",TFAILED,! 345 W ! 346 ; W "THE TESTS!",! 347 ; ZWR ZTMP 348 Q 349 ; 347 350 ZTEST(WHICH) ; RUN ONE SET OF TESTS 348 N ZTMP 349 D ZLOAD^GPLUNIT("ZTMP","GPLXPATH") 350 D ZTEST^GPLUNIT(.ZTMP,WHICH) 351 Q 352 ; 351 N ZTMP 352 S DEBUG=1 353 D ZLOAD^GPLUNIT("ZTMP","GPLXPATH") 354 D ZTEST^GPLUNIT(.ZTMP,WHICH) 355 Q 356 ; 353 357 TLIST ; LIST THE TESTS 354 358 N ZTMP … … 465 469 ;;>>>D ZTEST^GPLXPATH("INITXML") 466 470 ;;>>>D QOPEN^GPLXPATH("GBL","GXML") 467 ;;>>?$P(GBL(1)," ^",3)=12471 ;;>>?$P(GBL(1),";",3)=12 468 472 ;;>>>D BUILD^GPLXPATH("GBL","G2") 469 473 ;;>>?G2(G2(0))="</SECOND>" … … 472 476 ;;>>>D ZTEST^GPLXPATH("INITXML") 473 477 ;;>>>D QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND") 474 ;;>>?$P(GBL(1)," ^",3)=12478 ;;>>?$P(GBL(1),";",3)=11 475 479 ;;>>>D BUILD^GPLXPATH("GBL","G2") 476 480 ;;>>?G2(G2(0))="</SECOND>" … … 479 483 ;;>>>D ZTEST^GPLXPATH("INITXML") 480 484 ;;>>>D QCLOSE^GPLXPATH("GBL","GXML") 481 ;;>>?$P(GBL(1)," ^",3)=13485 ;;>>?$P(GBL(1),";",3)=13 482 486 ;;>>>D BUILD^GPLXPATH("GBL","G2") 483 487 ;;>>?G2(G2(0))="</FIRST>" … … 486 490 ;;>>>D ZTEST^GPLXPATH("INITXML") 487 491 ;;>>>D QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD") 488 ;;>>?$P(GBL(1)," ^",3)=13492 ;;>>?$P(GBL(1),";",3)=13 489 493 ;;>>>D BUILD^GPLXPATH("GBL","G2") 490 494 ;;>>?G2(G2(0))="</FIRST>" … … 494 498 ;;>>>D ZTEST^GPLXPATH("INITXML") 495 499 ;;>>>D QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2") 496 ;;>>>D INSERT^GPLXPATH("GXML","G2"," G3","//FIRST/SECOND/THIRD")497 ;;>>>D INSERT^GPLXPATH("G3","G2"," G4","//FIRST/SECOND/THIRD")498 ;;>>?G2(1)=G 3(9)500 ;;>>>D INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD") 501 ;;>>>D INSERT^GPLXPATH("G3","G2","//") 502 ;;>>?G2(1)=GXML(9) 499 503 ;;><REPLACE> 500 504 ;;>>>K G2,GBL,G3
Note:
See TracChangeset
for help on using the changeset viewer.
