Changeset 69 for ccr/trunk


Ignore:
Timestamp:
Jul 17, 2008, 3:55:07 PM (16 years ago)
Author:
George Lilly
Message:

added GPL license language

Location:
ccr/trunk/p
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • ccr/trunk/p/CCRDPT.m

    r48 r69  
    11CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    22          ;;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
    420          ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
    521          ; DESTROY to clean-up.
    6          
     22
    723          ; The first line of every routine tests if the global exists.
    8          
     24
    925          ; CCRDPT     83 lines  CCRCCD/SMH - Routines to Extract Patient Data for
    1026          ; INIT        9 lines  Copy DFN global to a local variable
     
    1329          ; GIVEN       6 lines  Given Name
    1430          ; MIDDLE      6 lines  Middle Name
    15           ; SUFFIX      6 lines  Suffix Name         
     31          ; SUFFIX      6 lines  Suffix Name
    1632          ; DISPNAME    5 lines  Display Name
    1733          ; DOB         6 lines  Date of Birth
     
    7288          ; EMERWTEL;   4 lines  EMER Work Telephone
    7389          ; EMERSAME;   4 lines  Is EMER's Address the same the NOK?
    74          
     90
    7591          W "No Entry at top!" Q
    76          
     92
    7793          ; 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] ^
    90106          ; ^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
    152168INIT(DFN) ; Copy DFN global to a local variable; PUBLIC
    153169          ; INPUT: Patient IEN (DFN)
    154170          ; OUTPUT: PT in the Symbol Table, representing the patient global
    155          
     171
    156172          ; Instead of accessing a global each single read (SLOOOOW)
    157173          ; read it off a local variable stored in Memory.
     
    179195          Q NAME("GIVEN")
    180196          ;
    181 MIDDLE() ; Middle Name; PUBLIC; Extrinsic 
     197MIDDLE() ; Middle Name; PUBLIC; Extrinsic
    182198          ; PREREQ: PT Defined
    183199          Q:$G(PT(0))="" ""
     
    191207          N NAME S NAME=$P(PT(0),"^",1)
    192208          D NAMECOMP^XLFNAME(.NAME)
    193           Q NAME("SUFFIX") 
     209          Q NAME("SUFFIX")
    194210          ;
    195211DISPNAME() ; Display Name; PUBLIC; Extrinsic
     
    197213          Q:$G(PT(0))="" ""
    198214          N NAME S NAME=$P(PT(0),"^",1)
    199           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 
     215          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    200216          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    201217DOB() ; Date of Birth; PUBLIC; Extrinsic
     
    248264          ;
    249265          ; 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] ^
    253269          Q:STATENUM="" ""  ; To prevent global undefined below if no state
    254270          Q $P(^DIC(5,STATENUM,0),"^",1)
     
    303319          Q NAME("GIVEN")
    304320          ;
    305 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic 
     321NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
    306322          ; PREREQ: PT Defined
    307323          Q:$G(PT(.21))="" ""
     
    315331          N NAME S NAME=$P(PT(.21),"^",1)
    316332          D NAMECOMP^XLFNAME(.NAME)
    317           Q NAME("SUFFIX") 
     333          Q NAME("SUFFIX")
    318334          ;
    319335NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic
     
    321337          Q:$G(PT(.21))="" ""
    322338          N NAME S NAME=$P(PT(.21),"^",1)
    323           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 
     339          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    324340          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    325341NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic
     
    388404          Q NAME("GIVEN")
    389405          ;
    390 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic 
     406NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
    391407          ; PREREQ: PT Defined
    392408          Q:$G(PT(.211))="" ""
     
    400416          N NAME S NAME=$P(PT(.211),"^",1)
    401417          D NAMECOMP^XLFNAME(.NAME)
    402           Q NAME("SUFFIX") 
     418          Q NAME("SUFFIX")
    403419NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic
    404420          ; PREREQ: PT Defined
    405421          Q:$G(PT(.211))="" ""
    406422          N NAME S NAME=$P(PT(.211),"^",1)
    407           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 
     423          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    408424          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    409425NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic
     
    455471          ;
    456472NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic
    457           ; PREREQ: PT Defined 
     473          ; PREREQ: PT Defined
    458474          Q:$G(PT(.211))="" ""
    459475          Q $P(PT(.211),"^",10)
    460           ; 
     476          ;
    461477EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic
    462478          ; PREREQ: PT Defined
     
    473489          Q NAME("GIVEN")
    474490          ;
    475 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic 
     491EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
    476492          ; PREREQ: PT Defined
    477493          Q:$G(PT(.33))="" ""
     
    485501          N NAME S NAME=$P(PT(.33),"^",1)
    486502          D NAMECOMP^XLFNAME(.NAME)
    487           Q NAME("SUFFIX") 
     503          Q NAME("SUFFIX")
    488504EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic
    489505          ; PREREQ: PT Defined
    490506          Q:$G(PT(.33))="" ""
    491507          N NAME S NAME=$P(PT(.33),"^",1)
    492           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc") 
     508          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    493509          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    494510EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic
     
    540556          ;
    541557EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic
    542           ; PREREQ: PT Defined 
     558          ; PREREQ: PT Defined
    543559          Q:$G(PT(.33))="" ""
    544560          Q $P(PT(.33),"^",10)
    545           ; 
     561          ;
  • ccr/trunk/p/CCRDPTT.m

    r40 r69  
    11CCRDPTT ; 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.
    319          ; Get the functions in the routine using Rick's routine
    420          ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860"
     
    1127          ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic "
    1228          ; etc.
    13          
     29
    1430          ; Load Routine Entry points; We get a sweeeeeet array
    1531          D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory
  • ccr/trunk/p/CCRSYS.m

    r49 r69  
    11CCRSYS ;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
    321
    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
    526
    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.
    1228
    1329SYSNAME() ;Get EHR System Name; PUBLIC; Extrinsic
    14         Q "WorldVistA EHR/VOE"
    15         ;
     30        Q "WorldVistA EHR/VOE"
     31        ;
    1632SYSVER() ;Get EHR System Version; PUBLIC; Extrinsic
    17         Q "1.0"
    18         ;
     33        Q "1.0"
     34        ;
    1935
  • ccr/trunk/p/CCRUTIL.m

    r64 r69  
    11CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    22          ;;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    ;
    420          W "No Entry at Top!" Q
    5          
     21
    622FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
    723          ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
     
    1026          ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
    1127          ; 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
    1329          S Y=1700+$E(DATE,1,3)
    1430          S M=$E(DATE,4,5)
     
    2339          S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
    2440          I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
    25           E  Q $P(UTC,"T") 
     41          E  Q $P(UTC,"T")
    2642          ;
  • ccr/trunk/p/CCRVA200.m

    r66 r69  
    11CCRVA200 ;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.
    622
    7         ; The Global is VA(200,*)
     23        ; The Global is VA(200,*)
    824
    925FAMILY(DUZ) ; Get Family Name; PUBLIC; EXTRINSIC
    10         ; INPUT: DUZ (i.e. File 200 IEN) ByVal
    11         ; OUTPUT: String
    12         N NAME S NAME=$P(^VA(200,DUZ,0),U)
    13         D NAMECOMP^XLFNAME(.NAME)
    14         Q NAME("FAMILY")
    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        ;
    1632GIVEN(DUZ) ; Get Given Name; PUBLIC; EXTRINSIC
    17         ; INPUT: DUZ ByVal
    18         ; OUTPUT: String
    19         N NAME S NAME=$P(^VA(200,DUZ,0),U)
    20         D NAMECOMP^XLFNAME(.NAME)
    21         Q NAME("GIVEN")
    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        ;
    2339MIDDLE(DUZ) ; Get Middle Name, PUBLIC; EXTRINSIC
    24         ; INPUT: DUZ ByVal
    25         ; OUTPUT: String
    26         N NAME S NAME=$P(^VA(200,DUZ,0),U)
    27         D NAMECOMP^XLFNAME(.NAME)
    28         Q NAME("MIDDLE")
    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        ;
    3046SUFFIX(DUZ) ; Get Suffix Name, PUBLIC; EXTRINSIC
    31         ; INPUT: DUZ ByVal
    32         ; OUTPUT: String
    33         N NAME S NAME=$P(^VA(200,DUZ,0),U)
    34         D NAMECOMP^XLFNAME(.NAME)
    35         Q NAME("SUFFIX")
    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        ;
    3753TITLE(DUZ) ; Get Title for Proivder, PUBLIC; EXTRINSIC
    38         ; INPUT: DUZ ByVal
    39         ; OUTPUT: String
    40         ; Gets External Value of Title field in New Person File.
    41         ; It's actually a pointer to file 3.1
    42         ; 200=New Person File; 8 is Title Field
    43         Q $$GET1^DIQ(200,DUZ_",",8)
    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        ;
    4561NPI(DUZ) ; Get NPI Number, PUBLIC; EXTRINSIC
    46         ; INPUT: DUZ ByVal
    47         ; OUTPUT: Delimited String in format:
    48         ;       IDType^ID^IDDescription
    49         ; If the NPI doesn't exist, "" is returned.
    50         ; This routine uses a call documented in the Kernel dev guide
    51         ; This call returns as "NPI^TimeEntered^ActiveInactive"
    52         ; It returns -1 for NPI if NPI doesn't exist.
    53         N NPI S NPI=$P($$NPI^XUSNPI("Individual_ID",DUZ),U)
    54         Q:NPI=-1 ""
    55         Q "NPI^"_NPI_"^HHS"
    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        ;
    5773SPEC(DUZ) ; Get Provider Specialty, PUBLIC; EXTRINSIC
    58         ; INPUT: DUZ ByVal
    59         ; OUTPUT: String: ProviderType/Specialty/Subspecialty OR ""
    60         ; Uses a Kernel API. Returns -1 if a specialty is not specified
    61         ;       in file 200.
    62         ; Otherwise, returns IEN^Profession^Specialty^Sub­            specialty^Effect date^Expired date^VA code
    63         N STR S STR=$$GET^XUA4A72(DUZ)
    64         Q:+STR<0 ""
    65         ; Sometimes we have 3 pieces, or 2. Deal with that.
    66         Q:$L($P(STR,U,4)) $P(STR,U,2)_"-"_$P(STR,U,3)_"-"_$P(STR,U,4)
    67         Q $P(STR,U,2)_"-"_$P(STR,U,3)
    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        ;
    6985ADDTYPE(DUZ) ; Get Address Type, PUBLIC; EXTRINSIC
    70         ; INPUT: DUZ, but not needed really... here for future expansion
    71         ; OUTPUT: At this point "Work"
    72         Q "Work"
    73         ;
     86        ; INPUT: DUZ, but not needed really... here for future expansion
     87        ; OUTPUT: At this point "Work"
     88        Q "Work"
     89        ;
    7490ADDLINE1(DUZ) ; Get Address associated with this instituation; PUBLIC; EXTRINSIC
    75         ; INPUT: DUZ ByVal
    76         ; Output: String.
     91        ; INPUT: DUZ ByVal
     92        ; Output: String.
    7793
    78         ; First, get site number from the institution file.
    79         ; 1st piece returned by $$SITE^VASITE, which gets the system institution
    80         N INST S INST=$P($$SITE^VASITE(),U)
     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)
    8197
    82         ; Second, get mailing address
    83         ; There are two APIs to get the address, one for physical and one for
    84         ; mailing. We will check if mailing exists first, since that's the
    85         ; one we want to use; then check for physical. If neither exists,
    86         ; then we return nothing. We check for the existence of an address
    87         ; by the length of the returned string.
    88         ; NOTE: API doesn't support Address 2, so I won't even include it
    89         ; in the template.
    90         N ADD
    91         S ADD=$$MADD^XUAF4(INST) ; mailing address
    92         Q:$L(ADD) $P(ADD,U)
    93         S ADD=$$PADD^XUAF4(INST) ; physical address
    94         Q:$L(ADD) $P(ADD,U)
    95         Q ""
    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        ;
    97113CITY(DUZ) ; Get City for Institution. PUBLIC; EXTRINSIC
    98         ; INPUT: DUZ ByVal
    99         ; Output: String.
    100         ; See ADD1 for comments
    101         N INST S INST=$P($$SITE^VASITE(),U)
    102         N ADD
    103         S ADD=$$MADD^XUAF4(INST) ; mailing address
    104         Q:$L(ADD) $P(ADD,U,2)
    105         S ADD=$$PADD^XUAF4(INST) ; physical address
    106         Q:$L(ADD) $P(ADD,U,2)
    107         Q ""
    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        ;
    109125STATE(DUZ) ; Get State for Institution. PUBLIC; EXTRINSIC
    110         ; INPUT: DUZ ByVal
    111         ; Output: String.
    112         ; See ADD1 for comments
    113         N INST S INST=$P($$SITE^VASITE(),U)
    114         N ADD
    115         S ADD=$$MADD^XUAF4(INST) ; mailing address
    116         Q:$L(ADD) $P(ADD,U,3)
    117         S ADD=$$PADD^XUAF4(INST) ; physical address
    118         Q:$L(ADD) $P(ADD,U,3)
    119         Q ""
    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        ;
    121137POSTCODE(DUZ) ; Get Postal Code for Institution. PUBLIC; EXTRINSIC
    122         ; INPUT: DUZ ByVal
    123         ; OUTPUT: String.
    124         ; See ADD1 for comments
    125         N INST S INST=$P($$SITE^VASITE(),U)
    126         N ADD
    127         S ADD=$$MADD^XUAF4(INST) ; mailing address
    128         Q:$L(ADD) $P(ADD,U,4)
    129         S ADD=$$PADD^XUAF4(INST) ; physical address
    130         Q:$L(ADD) $P(ADD,U,4)
    131         Q ""
    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        ;
    133149TEL(DUZ) ; Get Office Phone number. PUBLIC; EXTRINSIC
    134         ; INPUT: DUZ ByVal
    135         ; OUTPUT: String.
    136         ; Direct global access
    137         N TEL S TEL=$G(^VA(200,DUZ,.13))
    138         Q $P(TEL,U,2)
    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        ;
    140156TELTYPE(DUZ) ; Get Telephone Type. PUBLIC; EXTRINSIC
    141         ; INPUT: DUZ ByVal
    142         ; OUTPUT: String.
    143         Q "Office"
    144         ;
     157        ; INPUT: DUZ ByVal
     158        ; OUTPUT: String.
     159        Q "Office"
     160        ;
    145161EMAIL(DUZ) ; Get Provider's Email. PUBLIC; EXTRINSIC
    146         ; INPUT: DUZ ByVal
    147         ; OUTPUT: String
    148         ; Direct global access
    149         N EMAIL S EMAIL=$G(^VA(200,DUZ,.15))
    150         Q $P(EMAIL,U)
    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        ;
    152168
Note: See TracChangeset for help on using the changeset viewer.