iSharkFly-Open
/
VistA-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added GPL license language

This commit is contained in:
george 2008-07-17 19:55:07 +00:00
parent 0da20e3a27
commit 89cbb25a0c
5 changed files with 328 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

214
p/CCRDPT.m
View File

@ -1,18 +1,34 @@
CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
;;0.1;CCRCCD;;Jun 15, 2008;
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
; DESTROY to clean-up.
; The first line of every routine tests if the global exists.
; CCRDPT 83 lines CCRCCD/SMH - Routines to Extract Patient Data for
; INIT 9 lines Copy DFN global to a local variable
; DESTROY 6 lines Kill local variable
; FAMILY 6 lines Family Name
; GIVEN 6 lines Given Name
; MIDDLE 6 lines Middle Name
; SUFFIX 6 lines Suffix Name
; SUFFIX 6 lines Suffix Name
; DISPNAME 5 lines Display Name
; DOB 6 lines Date of Birth
; GENDER 4 lines Get Gender
@ -71,88 +87,88 @@ CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
; EMERHTEL; 4 lines EMER Home Telephone
; EMERWTEL; 4 lines EMER Work Telephone
; EMERSAME; 4 lines Is EMER's Address the same the NOK?
W "No Entry at top!" Q
; The following is a map of the relevant data in the patient global.
;
; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^
; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07)
; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09)
; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092)
; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE]
; ==>[12P:5] ^ ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^
; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO
; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081)
; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^
; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR
; ==>[21S] ^
;
; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^
; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07)
; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09)
; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092)
; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE]
; ==>[12P:5] ^ ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^
; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO
; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081)
; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^
; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR
; ==>[21S] ^
; ^DPT(D0,.01,0)=^2.01^^ (#1) ALIAS
; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS
; ==>COMPONENTS [3P:20] ^
; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS
; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114)
; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^
; ==>(#.117) COUNTY [7N] ^ ^ ^ ^ ^ (#.1112) ZIP+4 [12F] ^
; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE
; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD
; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200]
; ==>^
; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY
; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F]
; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE
; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY
; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE
; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219)
; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS
; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113)
; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^
; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^
; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER
; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER
; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL
; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE
; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139)
; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER
; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE
; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313)
; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE
; ==>SITE [14P:4] ^
; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO
; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214)
; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE
; ==>3] [5F] ^
; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP
; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS
; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F]
; ==>^
; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192)
; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS
; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^
; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY
; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^
; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS
; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^
; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP
; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2]
; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255)
; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S
; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258)
; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^ ^ ^ ^ ^ ^ (#.2514)
; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS
; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^
; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^
; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET
; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F]
; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP
; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER.
; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER
; ==>[11F] ^
; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS
; ==>COMPONENTS [3P:20] ^
; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS
; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114)
; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^
; ==>(#.117) COUNTY [7N] ^ ^ ^ ^ ^ (#.1112) ZIP+4 [12F] ^
; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE
; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD
; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200]
; ==>^
; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY
; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F]
; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE
; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY
; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE
; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219)
; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS
; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113)
; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^
; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^
; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER
; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER
; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL
; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE
; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139)
; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER
; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE
; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313)
; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE
; ==>SITE [14P:4] ^
; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO
; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214)
; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE
; ==>3] [5F] ^
; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP
; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS
; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F]
; ==>^
; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192)
; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS
; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^
; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY
; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^
; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS
; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^
; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP
; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2]
; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255)
; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S
; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258)
; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^ ^ ^ ^ ^ ^ (#.2514)
; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS
; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^
; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^
; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET
; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F]
; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP
; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER.
; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER
; ==>[11F] ^
INIT(DFN) ; Copy DFN global to a local variable; PUBLIC
; INPUT: Patient IEN (DFN)
; OUTPUT: PT in the Symbol Table, representing the patient global
; Instead of accessing a global each single read (SLOOOOW)
; read it off a local variable stored in Memory.
M PT=^DPT(DFN)
@ -178,7 +194,7 @@ GIVEN() ; Given Name; PUBLIC; Extrinsic
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
MIDDLE() ; Middle Name; PUBLIC; Extrinsic
MIDDLE() ; Middle Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(0))="" ""
N NAME S NAME=$P(PT(0),"^",1)
@ -190,13 +206,13 @@ SUFFIX() ; Suffi Name; PUBLIC; Extrinsic
Q:$G(PT(0))="" ""
N NAME S NAME=$P(PT(0),"^",1)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
Q NAME("SUFFIX")
;
DISPNAME() ; Display Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(0))="" ""
N NAME S NAME=$P(PT(0),"^",1)
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
DOB() ; Date of Birth; PUBLIC; Extrinsic
; PREREQ: PT Defined
@ -247,9 +263,9 @@ STATE() ; Get State for Home Address; PUBLIC; Extrinsic
N STATENUM S STATENUM=$P(PT(.11),"^",5)
;
; State File Global is below
; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE
; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2)
; ==>US STATE OR POSSESSION [6S] ^
; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE
; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2)
; ==>US STATE OR POSSESSION [6S] ^
Q:STATENUM="" "" ; To prevent global undefined below if no state
Q $P(^DIC(5,STATENUM,0),"^",1)
;
@ -302,7 +318,7 @@ NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.21))="" ""
N NAME S NAME=$P(PT(.21),"^",1)
@ -314,13 +330,13 @@ NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic
Q:$G(PT(.21))="" ""
N NAME S NAME=$P(PT(.21),"^",1)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
Q NAME("SUFFIX")
;
NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.21))="" ""
N NAME S NAME=$P(PT(.21),"^",1)
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic
; PREREQ: PT Defined
@ -387,7 +403,7 @@ NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.211))="" ""
N NAME S NAME=$P(PT(.211),"^",1)
@ -399,12 +415,12 @@ NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic
Q:$G(PT(.211))="" ""
N NAME S NAME=$P(PT(.211),"^",1)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
Q NAME("SUFFIX")
NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.211))="" ""
N NAME S NAME=$P(PT(.211),"^",1)
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic
; PREREQ: PT Defined
@ -454,10 +470,10 @@ NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic
Q $P(PT(.211),"^",11)
;
NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic
; PREREQ: PT Defined
; PREREQ: PT Defined
Q:$G(PT(.211))="" ""
Q $P(PT(.211),"^",10)
;
;
EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.33))="" ""
@ -472,7 +488,7 @@ EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.33))="" ""
N NAME S NAME=$P(PT(.33),"^",1)
@ -484,12 +500,12 @@ EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic
Q:$G(PT(.33))="" ""
N NAME S NAME=$P(PT(.33),"^",1)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
Q NAME("SUFFIX")
EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic
; PREREQ: PT Defined
Q:$G(PT(.33))="" ""
N NAME S NAME=$P(PT(.33),"^",1)
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic
; PREREQ: PT Defined
@ -539,7 +555,7 @@ EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic
Q $P(PT(.33),"^",11)
;
EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic
; PREREQ: PT Defined
; PREREQ: PT Defined
Q:$G(PT(.33))="" ""
Q $P(PT(.33),"^",10)
;
;

20
p/CCRDPTT.m
View File

@ -1,5 +1,21 @@
CCRDPTT ; Unit Tester...
;
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
; Get the functions in the routine using Rick's routine
; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860"
; STATS(1,0)="CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08"
@ -10,7 +26,7 @@ CCRDPTT ; Unit Tester...
; STATS(105,0)="GIVEN() ; Given Name; PUBLIC; Extrinsic"
; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic "
; etc.
; Load Routine Entry points; We get a sweeeeeet array
D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory
N X,Y

40
p/CCRSYS.m
View File

@ -1,19 +1,35 @@
CCRSYS ;CCDCCR/SMH - Routine to Get EHR System Information;6JUL2008
;;0.1;CCDCCR;;;
;;0.1;CCDCCR;;;
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;
W "Enter at appropriate points." Q
W "Enter at appropriate points." Q
; Originally, I was going to use VEPERVER, but VEPERVER
; actually kills ^TMP($J), outputs it to the screen in a user-friendly
; manner (press any key to continue),
; and is really a very half finished routine
; Originally, I was going to use VEPERVER, but VEPERVER
; actually kills ^TMP($J), outputs it to the screen in a user-friendly
; manner (press any key to continue),
; and is really a very half finished routine
; So for now, I am hard-coding the values.
; So for now, I am hard-coding the values.
SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic
Q "WorldVistA EHR/VOE"
;
Q "WorldVistA EHR/VOE"
;
SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic
Q "1.0"
;
Q "1.0"
;

24
p/CCRUTIL.m
View File

@ -1,15 +1,31 @@
CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08
;;0.1;CCRCCD;;Jun 15, 2008;
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;
W "No Entry at Top!" Q
FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
; If not passed, or passed incorrectly, it's assumed that it is D.
; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
N UTC,Y,M,D,H,MM,S,OFF
N UTC,Y,M,D,H,MM,S,OFF
S Y=1700+$E(DATE,1,3)
S M=$E(DATE,4,5)
S D=$E(DATE,6,7)
@ -22,5 +38,5 @@ FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrins
S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00"
S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
E Q $P(UTC,"T")
E Q $P(UTC,"T")
;

278
p/CCRVA200.m
View File

@ -1,152 +1,168 @@
CCRVA200 ;WV/CCDCCR/SMH - Routine to get Provider Data;07/13/2008
;;0.1;CCDCCR;;JUL 13, 2007;Build 0
Q
; This routine uses Kernel APIs and Direct Global Access to get
; Proivder Data from File 200.
;;0.1;CCDCCR;;JUL 13, 2007;Build 0
;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
Q
; This routine uses Kernel APIs and Direct Global Access to get
; Proivder Data from File 200.
; The Global is VA(200,*)
; The Global is VA(200,*)
FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC
; INPUT: DUZ (i.e. File 200 IEN) ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("FAMILY")
;
; INPUT: DUZ (i.e. File 200 IEN) ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("FAMILY")
;
GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("GIVEN")
;
MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("MIDDLE")
;
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("MIDDLE")
;
SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
;
; INPUT: DUZ ByVal
; OUTPUT: String
N NAME S NAME=$P(^VA(200,DUZ,0),U)
D NAMECOMP^XLFNAME(.NAME)
Q NAME("SUFFIX")
;
TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String
; Gets External Value of Title field in New Person File.
; It's actually a pointer to file 3.1
; 200=New Person File; 8 is Title Field
Q $$GET1^DIQ(200,DUZ_",",8)
;
; INPUT: DUZ ByVal
; OUTPUT: String
; Gets External Value of Title field in New Person File.
; It's actually a pointer to file 3.1
; 200=New Person File; 8 is Title Field
Q $$GET1^DIQ(200,DUZ_",",8)
;
NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: Delimited String in format:
; IDType^ID^IDDescription
; If the NPI doesn't exist, "" is returned.
; This routine uses a call documented in the Kernel dev guide
; This call returns as "NPI^TimeEntered^ActiveInactive"
; It returns -1 for NPI if NPI doesn't exist.
N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
Q:NPI=-1 ""
Q "NPI^"_NPI_"^HHS"
;
; INPUT: DUZ ByVal
; OUTPUT: Delimited String in format:
; IDType^ID^IDDescription
; If the NPI doesn't exist, "" is returned.
; This routine uses a call documented in the Kernel dev guide
; This call returns as "NPI^TimeEntered^ActiveInactive"
; It returns -1 for NPI if NPI doesn't exist.
N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
Q:NPI=-1 ""
Q "NPI^"_NPI_"^HHS"
;
SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
; Uses a Kernel API. Returns -1 if a specialty is not specified
; in file 200.
; Otherwise, returns IEN^Profession^Specialty^Sub­ specialty^Effect date^Expired date^VA code
N STR S STR=$$GET^XUA4A72(DUZ)
Q:+STR<0 ""
; Sometimes we have 3 pieces, or 2. Deal with that.
Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
Q $P(STR,U,2)_"-"_$P(STR,U,3)
;
; INPUT: DUZ ByVal
; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
; Uses a Kernel API. Returns -1 if a specialty is not specified
; in file 200.
; Otherwise, returns IEN^Profession^Specialty^Sub­ specialty^Effect date^Expired date^VA code
N STR S STR=$$GET^XUA4A72(DUZ)
Q:+STR<0 ""
; Sometimes we have 3 pieces, or 2. Deal with that.
Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
Q $P(STR,U,2)_"-"_$P(STR,U,3)
;
ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC
; INPUT: DUZ, but not needed really... here for future expansion
; OUTPUT: At this point "Work"
Q "Work"
;
; INPUT: DUZ, but not needed really... here for future expansion
; OUTPUT: At this point "Work"
Q "Work"
;
ADDLINE1(DUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; Output: String.
; INPUT: DUZ ByVal
; Output: String.
; First, get site number from the institution file.
; 1st piece returned by $$SITE^VASITE, which gets the system institution
N INST S INST=$P($$SITE^VASITE(),U)
; First, get site number from the institution file.
; 1st piece returned by $$SITE^VASITE, which gets the system institution
N INST S INST=$P($$SITE^VASITE(),U)
; Second, get mailing address
; There are two APIs to get the address, one for physical and one for
; mailing. We will check if mailing exists first, since that's the
; one we want to use; then check for physical. If neither exists,
; then we return nothing. We check for the existence of an address
; by the length of the returned string.
; NOTE: API doesn't support Address 2, so I won't even include it
; in the template.
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U)
Q ""
;
; Second, get mailing address
; There are two APIs to get the address, one for physical and one for
; mailing. We will check if mailing exists first, since that's the
; one we want to use; then check for physical. If neither exists,
; then we return nothing. We check for the existence of an address
; by the length of the returned string.
; NOTE: API doesn't support Address 2, so I won't even include it
; in the template.
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U)
Q ""
;
CITY(DUZ) ; Get City for Institution. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; Output: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,2)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,2)
Q ""
;
; INPUT: DUZ ByVal
; Output: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,2)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,2)
Q ""
;
STATE(DUZ) ; Get State for Institution. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; Output: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,3)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,3)
Q ""
;
; INPUT: DUZ ByVal
; Output: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,3)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,3)
Q ""
;
POSTCODE(DUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,4)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,4)
Q ""
;
; INPUT: DUZ ByVal
; OUTPUT: String.
; See ADD1 for comments
N INST S INST=$P($$SITE^VASITE(),U)
N ADD
S ADD=$$MADD^XUAF4(INST) ; mailing address
Q:$L(ADD) $P(ADD,U,4)
S ADD=$$PADD^XUAF4(INST) ; physical address
Q:$L(ADD) $P(ADD,U,4)
Q ""
;
TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String.
; Direct global access
N TEL S TEL=$G(^VA(200,DUZ,.13))
Q $P(TEL,U,2)
;
; INPUT: DUZ ByVal
; OUTPUT: String.
; Direct global access
N TEL S TEL=$G(^VA(200,DUZ,.13))
Q $P(TEL,U,2)
;
TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String.
Q "Office"
;
; INPUT: DUZ ByVal
; OUTPUT: String.
Q "Office"
;
EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC
; INPUT: DUZ ByVal
; OUTPUT: String
; Direct global access
N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
Q $P(EMAIL,U)
;
; INPUT: DUZ ByVal
; OUTPUT: String
; Direct global access
N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
Q $P(EMAIL,U)
;