- Timestamp:
- Jul 17, 2008, 3:55:07 PM (16 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/CCRDPT.m
r48 r69 1 1 CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08 2 2 ;;0.1;CCRCCD;;Jun 15, 2008; 3 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 4 20 ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and 5 21 ; DESTROY to clean-up. 6 22 7 23 ; The first line of every routine tests if the global exists. 8 24 9 25 ; CCRDPT 83 lines CCRCCD/SMH - Routines to Extract Patient Data for 10 26 ; INIT 9 lines Copy DFN global to a local variable … … 13 29 ; GIVEN 6 lines Given Name 14 30 ; MIDDLE 6 lines Middle Name 15 ; SUFFIX 6 lines Suffix Name 31 ; SUFFIX 6 lines Suffix Name 16 32 ; DISPNAME 5 lines Display Name 17 33 ; DOB 6 lines Date of Birth … … 72 88 ; EMERWTEL; 4 lines EMER Work Telephone 73 89 ; EMERSAME; 4 lines Is EMER's Address the same the NOK? 74 90 75 91 W "No Entry at top!" Q 76 92 77 93 ; The following is a map of the relevant data in the patient global. 78 ; 79 ; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^ 80 ; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07) 81 ; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09) 82 ; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092) 83 ; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE] 84 ; ==>[12P:5] ^ ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^ 85 ; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO 86 ; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081) 87 ; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^ 88 ; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR 89 ; ==>[21S] ^ 94 ; 95 ; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^ 96 ; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07) 97 ; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09) 98 ; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092) 99 ; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE] 100 ; ==>[12P:5] ^ ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^ 101 ; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO 102 ; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081) 103 ; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^ 104 ; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR 105 ; ==>[21S] ^ 90 106 ; ^DPT(D0,.01,0)=^2.01^^ (#1) ALIAS 91 ; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS 92 ; ==>COMPONENTS [3P:20] ^ 93 ; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS 94 ; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114) 95 ; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^ 96 ; ==>(#.117) COUNTY [7N] ^ ^ ^ ^ ^ (#.1112) ZIP+4 [12F] ^ 97 ; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE 98 ; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD 99 ; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200] 100 ; ==>^ 101 ; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY 102 ; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F] 103 ; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE 104 ; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY 105 ; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE 106 ; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219) 107 ; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS 108 ; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113) 109 ; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^ 110 ; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^ 111 ; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER 112 ; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER 113 ; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL 114 ; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE 115 ; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139) 116 ; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER 117 ; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE 118 ; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313) 119 ; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE 120 ; ==>SITE [14P:4] ^ 121 ; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO 122 ; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214) 123 ; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE 124 ; ==>3] [5F] ^ 125 ; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP 126 ; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS 127 ; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F] 128 ; ==>^ 129 ; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192) 130 ; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS 131 ; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^ 132 ; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY 133 ; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^ 134 ; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS 135 ; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^ 136 ; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP 137 ; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2] 138 ; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255) 139 ; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S 140 ; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258) 141 ; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^ ^ ^ ^ ^ ^ (#.2514) 142 ; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS 143 ; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^ 144 ; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^ 145 ; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET 146 ; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F] 147 ; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP 148 ; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER. 149 ; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER 150 ; ==>[11F] ^ 151 107 ; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS 108 ; ==>COMPONENTS [3P:20] ^ 109 ; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS 110 ; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114) 111 ; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^ 112 ; ==>(#.117) COUNTY [7N] ^ ^ ^ ^ ^ (#.1112) ZIP+4 [12F] ^ 113 ; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE 114 ; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD 115 ; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200] 116 ; ==>^ 117 ; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY 118 ; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F] 119 ; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE 120 ; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY 121 ; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE 122 ; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219) 123 ; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS 124 ; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113) 125 ; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^ 126 ; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^ 127 ; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER 128 ; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER 129 ; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL 130 ; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE 131 ; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139) 132 ; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER 133 ; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE 134 ; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313) 135 ; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE 136 ; ==>SITE [14P:4] ^ 137 ; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO 138 ; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214) 139 ; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE 140 ; ==>3] [5F] ^ 141 ; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP 142 ; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS 143 ; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F] 144 ; ==>^ 145 ; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192) 146 ; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS 147 ; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^ 148 ; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY 149 ; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^ 150 ; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS 151 ; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^ 152 ; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP 153 ; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2] 154 ; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255) 155 ; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S 156 ; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258) 157 ; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^ ^ ^ ^ ^ ^ (#.2514) 158 ; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS 159 ; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^ 160 ; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^ 161 ; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET 162 ; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F] 163 ; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP 164 ; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER. 165 ; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER 166 ; ==>[11F] ^ 167 152 168 INIT(DFN) ; Copy DFN global to a local variable; PUBLIC 153 169 ; INPUT: Patient IEN (DFN) 154 170 ; OUTPUT: PT in the Symbol Table, representing the patient global 155 171 156 172 ; Instead of accessing a global each single read (SLOOOOW) 157 173 ; read it off a local variable stored in Memory. … … 179 195 Q NAME("GIVEN") 180 196 ; 181 MIDDLE() ; Middle Name; PUBLIC; Extrinsic 197 MIDDLE() ; Middle Name; PUBLIC; Extrinsic 182 198 ; PREREQ: PT Defined 183 199 Q:$G(PT(0))="" "" … … 191 207 N NAME S NAME=$P(PT(0),"^",1) 192 208 D NAMECOMP^XLFNAME(.NAME) 193 Q NAME("SUFFIX") 209 Q NAME("SUFFIX") 194 210 ; 195 211 DISPNAME() ; Display Name; PUBLIC; Extrinsic … … 197 213 Q:$G(PT(0))="" "" 198 214 N NAME S NAME=$P(PT(0),"^",1) 199 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 215 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 200 216 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 201 217 DOB() ; Date of Birth; PUBLIC; Extrinsic … … 248 264 ; 249 265 ; State File Global is below 250 ; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE 251 ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2) 252 ; ==>US STATE OR POSSESSION [6S] ^ 266 ; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE 267 ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2) 268 ; ==>US STATE OR POSSESSION [6S] ^ 253 269 Q:STATENUM="" "" ; To prevent global undefined below if no state 254 270 Q $P(^DIC(5,STATENUM,0),"^",1) … … 303 319 Q NAME("GIVEN") 304 320 ; 305 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic 321 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic 306 322 ; PREREQ: PT Defined 307 323 Q:$G(PT(.21))="" "" … … 315 331 N NAME S NAME=$P(PT(.21),"^",1) 316 332 D NAMECOMP^XLFNAME(.NAME) 317 Q NAME("SUFFIX") 333 Q NAME("SUFFIX") 318 334 ; 319 335 NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic … … 321 337 Q:$G(PT(.21))="" "" 322 338 N NAME S NAME=$P(PT(.21),"^",1) 323 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 339 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 324 340 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 325 341 NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic … … 388 404 Q NAME("GIVEN") 389 405 ; 390 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic 406 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic 391 407 ; PREREQ: PT Defined 392 408 Q:$G(PT(.211))="" "" … … 400 416 N NAME S NAME=$P(PT(.211),"^",1) 401 417 D NAMECOMP^XLFNAME(.NAME) 402 Q NAME("SUFFIX") 418 Q NAME("SUFFIX") 403 419 NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic 404 420 ; PREREQ: PT Defined 405 421 Q:$G(PT(.211))="" "" 406 422 N NAME S NAME=$P(PT(.211),"^",1) 407 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 423 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 408 424 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 409 425 NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic … … 455 471 ; 456 472 NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic 457 ; PREREQ: PT Defined 473 ; PREREQ: PT Defined 458 474 Q:$G(PT(.211))="" "" 459 475 Q $P(PT(.211),"^",10) 460 ; 476 ; 461 477 EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic 462 478 ; PREREQ: PT Defined … … 473 489 Q NAME("GIVEN") 474 490 ; 475 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic 491 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic 476 492 ; PREREQ: PT Defined 477 493 Q:$G(PT(.33))="" "" … … 485 501 N NAME S NAME=$P(PT(.33),"^",1) 486 502 D NAMECOMP^XLFNAME(.NAME) 487 Q NAME("SUFFIX") 503 Q NAME("SUFFIX") 488 504 EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic 489 505 ; PREREQ: PT Defined 490 506 Q:$G(PT(.33))="" "" 491 507 N NAME S NAME=$P(PT(.33),"^",1) 492 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 508 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 493 509 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma 494 510 EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic … … 540 556 ; 541 557 EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic 542 ; PREREQ: PT Defined 558 ; PREREQ: PT Defined 543 559 Q:$G(PT(.33))="" "" 544 560 Q $P(PT(.33),"^",10) 545 ; 561 ; -
ccr/trunk/p/CCRDPTT.m
r40 r69 1 1 CCRDPTT ; Unit Tester... 2 2 ; 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. 3 19 ; Get the functions in the routine using Rick's routine 4 20 ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860" … … 11 27 ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic " 12 28 ; etc. 13 29 14 30 ; Load Routine Entry points; We get a sweeeeeet array 15 31 D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory -
ccr/trunk/p/CCRSYS.m
r49 r69 1 1 CCRSYS ;CCDCCR/SMH - Routine to Get EHR System Information;6JUL2008 2 ;;0.1;CCDCCR;;; 2 ;;0.1;CCDCCR;;; 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 3 21 4 W "Enter at appropriate points." Q 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 5 26 6 ; Originally, I was going to use VEPERVER, but VEPERVER 7 ; actually kills ^TMP($J), outputs it to the screen in a user-friendly 8 ; manner (press any key to continue), 9 ; and is really a very half finished routine 10 11 ; So for now, I am hard-coding the values. 27 ; So for now, I am hard-coding the values. 12 28 13 29 SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic 14 15 30 Q "WorldVistA EHR/VOE" 31 ; 16 32 SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic 17 18 33 Q "1.0" 34 ; 19 35 -
ccr/trunk/p/CCRUTIL.m
r64 r69 1 1 CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 2 ;;0.1;CCRCCD;;Jun 15, 2008; 3 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 ; 4 20 W "No Entry at Top!" Q 5 21 6 22 FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic 7 23 ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) … … 10 26 ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC 11 27 ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) 12 N UTC,Y,M,D,H,MM,S,OFF 28 N UTC,Y,M,D,H,MM,S,OFF 13 29 S Y=1700+$E(DATE,1,3) 14 30 S M=$E(DATE,4,5) … … 23 39 S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds 24 40 I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. 25 E Q $P(UTC,"T") 41 E Q $P(UTC,"T") 26 42 ; -
ccr/trunk/p/CCRVA200.m
r66 r69 1 1 CCRVA200 ;WV/CCDCCR/SMH - Routine to get Provider Data;07/13/2008 2 ;;0.1;CCDCCR;;JUL 13, 2007;Build 0 3 Q 4 ; This routine uses Kernel APIs and Direct Global Access to get 5 ; Proivder Data from File 200. 2 ;;0.1;CCDCCR;;JUL 13, 2007;Build 0 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 Q 20 ; This routine uses Kernel APIs and Direct Global Access to get 21 ; Proivder Data from File 200. 6 22 7 23 ; The Global is VA(200,*) 8 24 9 25 FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC 10 11 12 13 14 15 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 ; 16 32 GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC 17 18 19 20 21 22 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 ; 23 39 MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC 24 25 26 27 28 29 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 ; 30 46 SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC 31 32 33 34 35 36 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 ; 37 53 TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC 38 39 40 41 42 43 44 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 ; 45 61 NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC 46 47 48 ;IDType^ID^IDDescription49 50 51 52 53 54 55 56 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 ; 57 73 SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC 58 59 60 61 ;in file 200.62 63 64 65 66 67 68 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^Sub specialty^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 ; 69 85 ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC 70 71 72 73 86 ; INPUT: DUZ, but not needed really... here for future expansion 87 ; OUTPUT: At this point "Work" 88 Q "Work" 89 ; 74 90 ADDLINE1(DUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC 75 76 91 ; INPUT: DUZ ByVal 92 ; Output: String. 77 93 78 79 80 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) 81 97 82 83 ; There are two APIs to get the address, one for physical and one for 84 85 86 87 88 89 90 N ADD 91 92 93 94 95 96 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 ; 97 113 CITY(DUZ) ; Get City for Institution. PUBLIC; EXTRINSIC 98 99 100 101 102 N ADD 103 104 105 106 107 108 114 ; INPUT: DUZ ByVal 115 ; Output: String. 116 ; See ADD1 for comments 117 N INST S INST=$P($$SITE^VASITE(),U) 118 N ADD 119 S ADD=$$MADD^XUAF4(INST) ; mailing address 120 Q:$L(ADD) $P(ADD,U,2) 121 S ADD=$$PADD^XUAF4(INST) ; physical address 122 Q:$L(ADD) $P(ADD,U,2) 123 Q "" 124 ; 109 125 STATE(DUZ) ; Get State for Institution. PUBLIC; EXTRINSIC 110 111 112 113 114 N ADD 115 116 117 118 119 120 126 ; INPUT: DUZ ByVal 127 ; Output: String. 128 ; See ADD1 for comments 129 N INST S INST=$P($$SITE^VASITE(),U) 130 N ADD 131 S ADD=$$MADD^XUAF4(INST) ; mailing address 132 Q:$L(ADD) $P(ADD,U,3) 133 S ADD=$$PADD^XUAF4(INST) ; physical address 134 Q:$L(ADD) $P(ADD,U,3) 135 Q "" 136 ; 121 137 POSTCODE(DUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC 122 123 124 125 126 N ADD 127 128 129 130 131 132 138 ; INPUT: DUZ ByVal 139 ; OUTPUT: String. 140 ; See ADD1 for comments 141 N INST S INST=$P($$SITE^VASITE(),U) 142 N ADD 143 S ADD=$$MADD^XUAF4(INST) ; mailing address 144 Q:$L(ADD) $P(ADD,U,4) 145 S ADD=$$PADD^XUAF4(INST) ; physical address 146 Q:$L(ADD) $P(ADD,U,4) 147 Q "" 148 ; 133 149 TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC 134 135 136 137 138 139 150 ; INPUT: DUZ ByVal 151 ; OUTPUT: String. 152 ; Direct global access 153 N TEL S TEL=$G(^VA(200,DUZ,.13)) 154 Q $P(TEL,U,2) 155 ; 140 156 TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC 141 142 143 144 157 ; INPUT: DUZ ByVal 158 ; OUTPUT: String. 159 Q "Office" 160 ; 145 161 EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC 146 147 148 149 150 151 162 ; INPUT: DUZ ByVal 163 ; OUTPUT: String 164 ; Direct global access 165 N EMAIL S EMAIL=$G(^VA(200,DUZ,.15)) 166 Q $P(EMAIL,U) 167 ; 152 168
Note:
See TracChangeset
for help on using the changeset viewer.
