Index: /ccr/trunk/p/CCRDPT.m =================================================================== --- /ccr/trunk/p/CCRDPT.m (revision 68) +++ /ccr/trunk/p/CCRDPT.m (revision 69) @@ -1,10 +1,26 @@ 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 @@ -13,5 +29,5 @@ ; 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 @@ -72,86 +88,86 @@ ; 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. @@ -179,5 +195,5 @@ Q NAME("GIVEN") ; -MIDDLE() ; Middle Name; PUBLIC; Extrinsic +MIDDLE() ; Middle Name; PUBLIC; Extrinsic ; PREREQ: PT Defined Q:$G(PT(0))="" "" @@ -191,5 +207,5 @@ N NAME S NAME=$P(PT(0),"^",1) D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") + Q NAME("SUFFIX") ; DISPNAME() ; Display Name; PUBLIC; Extrinsic @@ -197,5 +213,5 @@ 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 @@ -248,7 +264,7 @@ ; ; 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) @@ -303,5 +319,5 @@ Q NAME("GIVEN") ; -NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic +NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic ; PREREQ: PT Defined Q:$G(PT(.21))="" "" @@ -315,5 +331,5 @@ N NAME S NAME=$P(PT(.21),"^",1) D NAMECOMP^XLFNAME(.NAME) - Q NAME("SUFFIX") + Q NAME("SUFFIX") ; NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic @@ -321,5 +337,5 @@ 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 @@ -388,5 +404,5 @@ Q NAME("GIVEN") ; -NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic +NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic ; PREREQ: PT Defined Q:$G(PT(.211))="" "" @@ -400,10 +416,10 @@ 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 @@ -455,8 +471,8 @@ ; 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 @@ -473,5 +489,5 @@ Q NAME("GIVEN") ; -EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic +EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic ; PREREQ: PT Defined Q:$G(PT(.33))="" "" @@ -485,10 +501,10 @@ 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 @@ -540,6 +556,6 @@ ; 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) - ; + ; Index: /ccr/trunk/p/CCRDPTT.m =================================================================== --- /ccr/trunk/p/CCRDPTT.m (revision 68) +++ /ccr/trunk/p/CCRDPTT.m (revision 69) @@ -1,4 +1,20 @@ 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" @@ -11,5 +27,5 @@ ; 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 Index: /ccr/trunk/p/CCRSYS.m =================================================================== --- /ccr/trunk/p/CCRSYS.m (revision 68) +++ /ccr/trunk/p/CCRSYS.m (revision 69) @@ -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" + ; Index: /ccr/trunk/p/CCRUTIL.m =================================================================== --- /ccr/trunk/p/CCRUTIL.m (revision 68) +++ /ccr/trunk/p/CCRUTIL.m (revision 69) @@ -1,7 +1,23 @@ 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) @@ -10,5 +26,5 @@ ; 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) @@ -23,4 +39,4 @@ 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") ; Index: /ccr/trunk/p/CCRVA200.m =================================================================== --- /ccr/trunk/p/CCRVA200.m (revision 68) +++ /ccr/trunk/p/CCRVA200.m (revision 69) @@ -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) + ;