Changeset 175 for ccr/trunk/p


Ignore:
Timestamp:
Oct 3, 2008, 10:57:33 PM (16 years ago)
Author:
Sam Habiel
Message:

Refactored CCRDPT and updated GPLACTOR accordingly

Location:
ccr/trunk/p
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • ccr/trunk/p/CCRDPT.m

    r122 r175  
    1 CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2   ;;0.1;CCRCCD;;Jun 15, 2008;
    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     ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
    20     ; DESTROY to clean-up.
    21     ; The first line of every routine tests if the global exists.
    22     ;
    23     ; CCRDPT     83 lines  CCRCCD/SMH - Routines to Extract Patient Data for
    24     ; INIT        9 lines  Copy DFN global to a local variable
    25     ; DESTROY     6 lines  Kill local variable
    26     ; FAMILY      6 lines  Family Name
    27     ; GIVEN       6 lines  Given Name
    28     ; MIDDLE      6 lines  Middle Name
    29     ; SUFFIX      6 lines  Suffix Name
    30     ; DISPNAME    5 lines  Display Name
    31     ; DOB         6 lines  Date of Birth
    32     ; GENDER      4 lines  Get Gender
    33     ; SSN         4 lines  Get SSN for ID
    34     ; ADDRTYPE    4 lines  Get Home Address
    35     ; ADDR1       4 lines  Get Home Address line 1
    36     ; ADDR2       5 lines  Get Home Address line 2
    37     ; CITY        4 lines  Get City for Home Address
    38     ; STATE      11 lines  Get State for Home Address
    39     ; ZIP         4 lines  Get Zip code for Home Address
    40     ; COUNTY      4 lines  Get County for our Address
    41     ; COUNTRY     4 lines  Get Country for our Address
    42     ; RESTEL      4 lines  Residential Telephone
    43     ; WORKTEL     4 lines  Work Telephone
    44     ; EMAIL       4 lines  Email Adddress
    45     ; CELLTEL     4 lines  Cell Phone
    46     ; NOK1FAM     6 lines  Next of Kin 1 (NOK1) Family Name
    47     ; NOK1GIV     6 lines  NOK1 Given Name
    48     ; NOK1MID     6 lines  NOK1 Middle Name
    49     ; NOK1SUF     6 lines  NOK1 Suffi Name
    50     ; NOK1DISP    5 lines  NOK1 Display Name
    51     ; NOK1REL     4 lines  NOK1 Relationship to the patient
    52     ; NOK1ADD1    4 lines  NOK1 Address 1
    53     ; NOK1ADD2    5 lines  NOK1 Address 2
    54     ; NOK1CITY    4 lines  NOK1 City
    55     ; NOK1STAT    5 lines  NOK1 State
    56     ; NOK1ZIP     4 lines  NOK1 Zip Code
    57     ; NOK1HTEL;   4 lines  NOK1 Home Telephone
    58     ; NOK1WTEL;   4 lines  NOK1 Work Telephone
    59     ; NOK1SAME;   4 lines  Is NOK1's Address the same the patient?
    60     ; NOK2FAM     6 lines  NOK2 Family Name
    61     ; NOK2GIV     6 lines  NOK2 Given Name
    62     ; NOK2MID     6 lines  NOK2 Middle Name
    63     ; NOK2SUF     5 lines  NOK2 Suffi Name
    64     ; NOK2DISP    5 lines  NOK2 Display Name
    65     ; NOK2REL     4 lines  NOK2 Relationship to the patient
    66     ; NOK2ADD1    4 lines  NOK2 Address 1
    67     ; NOK2ADD2    5 lines  NOK2 Address 2
    68     ; NOK2CITY    4 lines  NOK2 City
    69     ; NOK2STAT    5 lines  NOK2 State
    70     ; NOK2ZIP     4 lines  NOK2 Zip Code
    71     ; NOK2HTEL;   4 lines  NOK2 Home Telephone
    72     ; NOK2WTEL;   4 lines  NOK2 Work Telephone
    73     ; NOK2SAME;   4 lines  Is NOK2's Address the same the patient?
    74     ; EMERFAM     6 lines  Emergency Contact (EMER) Family Name
    75     ; EMERGIV     6 lines  EMER Given Name
    76     ; EMERMID     6 lines  EMER Middle Name
    77     ; EMERSUF     5 lines  EMER Suffi Name
    78     ; EMERDISP    5 lines  EMER Display Name
    79     ; EMERREL     4 lines  EMER Relationship to the patient
    80     ; EMERADD1    4 lines  EMER Address 1
    81     ; EMERADD2    5 lines  EMER Address 2
    82     ; EMERCITY    4 lines  EMER City
    83     ; EMERSTAT    5 lines  EMER State
    84     ; EMERZIP     4 lines  EMER Zip Code
    85     ; EMERHTEL;   4 lines  EMER Home Telephone
    86     ; EMERWTEL;   4 lines  EMER Work Telephone
    87     ; EMERSAME;   4 lines  Is EMER's Address the same the NOK?
    88     ;
    89           W "No Entry at top!" Q
    90    ; The following is a map of the relevant data in the patient global.
    91     ;
    92     ; ^DPT(D0,0)= (#.01) NAME [1F] ^ (#.02) SEX [2S] ^ (#.03) DATE OF BIRTH [3D] ^
    93     ; ==>^ (#.05) MARITAL STATUS [5P:11] ^ (#.06) RACE [6P:10] ^ (#.07)
    94     ; ==>OCCUPATION [7F] ^ (#.08) RELIGIOUS PREFERENCE [8P:13] ^ (#.09)
    95     ; ==>SOCIAL SECURITY NUMBER [9F] ^ (#.091) REMARKS [10F] ^ (#.092)
    96     ; ==>PLACE OF BIRTH [CITY] [11F] ^ (#.093) PLACE OF BIRTH [STATE]
    97     ; ==>[12P:5] ^  ^ (#.14) CURRENT MEANS TEST STATUS [14P:408.32] ^
    98     ; ==>(#.096) WHO ENTERED PATIENT [15P:200] ^ (#.097) DATE ENTERED INTO
    99     ; ==>FILE [16D] ^ (#.098) HOW WAS PATIENT ENTERED? [17S] ^ (#.081)
    100     ; ==>DUPLICATE STATUS [18S] ^ (#.082) PATIENT MERGED TO [19P:2] ^
    101     ; ==>(#.083) CHECK FOR DUPLICATE [20S] ^ (#.6) TEST PATIENT INDICATOR
    102     ; ==>[21S] ^
    103     ; ^DPT(D0,.01,0)=^2.01^^  (#1) ALIAS
    104     ; ^DPT(D0,.01,D1,0)= (#.01) ALIAS [1F] ^ (#1) ALIAS SSN [2F] ^ (#100.03) ALIAS
    105     ; ==>COMPONENTS [3P:20] ^
    106     ; ^DPT(D0,.11)= (#.111) STREET ADDRESS [LINE 1] [1F] ^ (#.112) STREET ADDRESS
    107     ; ==>[LINE 2] [2F] ^ (#.113) STREET ADDRESS [LINE 3] [3F] ^ (#.114)
    108     ; ==>CITY [4F] ^ (#.115) STATE [5P:5] ^ (#.116) ZIP CODE [6F] ^
    109     ; ==>(#.117) COUNTY [7N] ^  ^  ^  ^  ^ (#.1112) ZIP+4 [12F] ^
    110     ; ==>(#.118) ADDRESS CHANGE DT/TM [13D] ^ (#.119) ADDRESS CHANGE
    111     ; ==>SOURCE [14S] ^ (#.12) ADDRESS CHANGE SITE [15P:4] ^ (#.121) BAD
    112     ; ==>ADDRESS INDICATOR [16S] ^ (#.122) ADDRESS CHANGE USER [17P:200]
    113     ; ==>^
    114     ; ^DPT(D0,.121)= (#.1211) TEMPORARY STREET [LINE 1] [1F] ^ (#.1212) TEMPORARY
    115     ; ==>STREET [LINE 2] [2F] ^ (#.1213) TEMPORARY STREET [LINE 3] [3F]
    116     ; ==>^ (#.1214) TEMPORARY CITY [4F] ^ (#.1215) TEMPORARY STATE
    117     ; ==>[5P:5] ^ (#.1216) TEMPORARY ZIP CODE [6F] ^ (#.1217) TEMPORARY
    118     ; ==>ADDRESS START DATE [7D] ^ (#.1218) TEMPORARY ADDRESS END DATE
    119     ; ==>[8D] ^ (#.12105) TEMPORARY ADDRESS ACTIVE? [9S] ^ (#.1219)
    120     ; ==>TEMPORARY PHONE NUMBER [10F] ^ (#.12111) TEMPORARY ADDRESS
    121     ; ==>COUNTY [11N] ^ (#.12112) TEMPORARY ZIP+4 [12F] ^ (#.12113)
    122     ; ==>TEMPORARY ADDRESS CHANGE DT/TM [13D] ^
    123     ; ^DPT(D0,.121)= (#.12114) TEMPORARY ADDRESS CHANGE SITE [14P:4] ^
    124     ; ^DPT(D0,.13)= (#.131) PHONE NUMBER [RESIDENCE] [1F] ^ (#.132) PHONE NUMBER
    125     ; ==>[WORK] [2F] ^ (#.133) EMAIL ADDRESS [3F] ^ (#.134) PHONE NUMBER
    126     ; ==>[CELLULAR] [4F] ^ (#.135) PAGER NUMBER [5F] ^ (#.136) EMAIL
    127     ; ==>ADDRESS CHANGE DT/TM [6D] ^ (#.137) EMAIL ADDRESS CHANGE SOURCE
    128     ; ==>[7S] ^ (#.138) EMAIL ADDRESS CHANGE SITE [8P:4] ^ (#.139)
    129     ; ==>CELLULAR NUMBER CHANGE DT/TM [9D] ^ (#.1311) CELLULAR NUMBER
    130     ; ==>CHANGE SOURCE [10S] ^ (#.13111) CELLULAR NUMBER CHANGE SITE
    131     ; ==>[11P:4] ^ (#.1312) PAGER NUMBER CHANGE DT/TM [12D] ^ (#.1313)
    132     ; ==>PAGER NUMBER CHANGE SOURCE [13S] ^ (#.1314) PAGER NUMBER CHANGE
    133     ; ==>SITE [14P:4] ^
    134     ; ^DPT(D0,.21)= (#.211) K-NAME OF PRIMARY NOK [1F] ^ (#.212) K-RELATIONSHIP TO
    135     ; ==>PATIENT [2F] ^ (#.213) K-STREET ADDRESS [LINE 1] [3F] ^ (#.214)
    136     ; ==>K-STREET ADDRESS [LINE 2] [4F] ^ (#.215) K-STREET ADDRESS [LINE
    137     ; ==>3] [5F] ^
    138     ; ^DPT(D0,.21)= (#.216) K-CITY [6F] ^ (#.217) K-STATE [7P:5] ^ (#.218) K-ZIP
    139     ; ==>CODE [8F] ^ (#.219) K-PHONE NUMBER [9F] ^ (#.2125) K-ADDRESS
    140     ; ==>SAME AS PATIENT'S? [10S] ^ (#.21011) K-WORK PHONE NUMBER [11F]
    141     ; ==>^
    142     ; ^DPT(D0,.211)= (#.2191) K2-NAME OF SECONDARY NOK [1F] ^ (#.2192)
    143     ; ==>K2-RELATIONSHIP TO PATIENT [2F] ^ (#.2193) K2-STREET ADDRESS
    144     ; ==>[LINE 1] [3F] ^ (#.2194) K2-STREET ADDRESS [LINE 2] [4F] ^
    145     ; ==>(#.2195) K2-STREET ADDRESS [LINE 3] [5F] ^ (#.2196) K2-CITY
    146     ; ==>[6F] ^ (#.2197) K2-STATE [7P:5] ^ (#.2198) K2-ZIP CODE [8F] ^
    147     ; ==>(#.2199) K2-PHONE NUMBER [9F] ^ (#.21925) K2-ADDRESS SAME AS
    148     ; ==>PATIENT'S? [10S] ^ (#.211011) K2-WORK PHONE NUMBER [11F] ^
    149     ; ^DPT(D0,.25)= (#.251) SPOUSE'S EMPLOYER NAME [1F] ^ (#.252) SPOUSE'S EMP
    150     ; ==>STREET [LINE 1] [2F] ^ (#.253) SPOUSE'S EMP STREET [LINE 2]
    151     ; ==>[3F] ^ (#.254) SPOUSE'S EMP STREET [LINE 3] [4F] ^ (#.255)
    152     ; ==>SPOUSE'S EMPLOYER'S CITY [5F] ^ (#.256) SPOUSE'S EMPLOYER'S
    153     ; ==>STATE [6P:5] ^ (#.257) SPOUSE'S EMP ZIP CODE [7F] ^ (#.258)
    154     ; ==>SPOUSE'S EMP PHONE NUMBER [8F] ^  ^  ^  ^  ^  ^ (#.2514)
    155     ; ==>SPOUSE'S OCCUPATION [14F] ^ (#.2515) SPOUSE'S EMPLOYMENT STATUS
    156     ; ==>[15S] ^ (#.2516) SPOUSE'S RETIREMENT DATE [16D] ^
    157     ; ^DPT(D0,.33)= (#.331) E-NAME [1F] ^ (#.332) E-RELATIONSHIP TO PATIENT [2F] ^
    158     ; ==>(#.333) E-STREET ADDRESS [LINE 1] [3F] ^ (#.334) E-STREET
    159     ; ==>ADDRESS [LINE 2] [4F] ^ (#.335) E-STREET ADDRESS [LINE 3] [5F]
    160     ; ==>^ (#.336) E-CITY [6F] ^ (#.337) E-STATE [7P:5] ^ (#.338) E-ZIP
    161     ; ==>CODE [8F] ^ (#.339) E-PHONE NUMBER [9F] ^ (#.3305) E-EMER.
    162     ; ==>CONTACT SAME AS NOK? [10S] ^ (#.33011) E-WORK PHONE NUMBER
    163     ; ==>[11F] ^DFN) ; Copy DFN global to a local variable; PUBLIC
    164     ; INPUT: Patient IEN (DFN)
    165     ; OUTPUT: PT in the Symbol Table, representing the patient global
    166     ; Instead of accessing a global each single read (SLOOOOW)
    167     ; read it off a local variable stored in Memory.
    168 INIT(DFN) ;
    169           M PT=^DPT(DFN)
    170           Q
    171           ;
    172 DESTROY ; Kill local variable; PUBLIC
    173           ; INPUT: None
    174           ; OUTPUT: Kill PT from the Symbol Table after you are done
    175           K PT
    176           Q
    177           ;
    178 FAMILY() ; Family Name; PUBLIC; Extrinsic
    179           ; PREREQ: PT Defined
    180           Q:$G(PT(0))="" ""
    181           N NAME S NAME=$P(PT(0),"^",1)
    182           D NAMECOMP^XLFNAME(.NAME)
    183           Q NAME("FAMILY")
    184           ;
    185 GIVEN() ; Given Name; PUBLIC; Extrinsic
    186           ; PREREQ: PT Defined
    187           Q:$G(PT(0))="" ""
    188           N NAME S NAME=$P(PT(0),"^",1)
    189           D NAMECOMP^XLFNAME(.NAME)
    190           Q NAME("GIVEN")
    191           ;
    192 MIDDLE() ; Middle Name; PUBLIC; Extrinsic
    193           ; PREREQ: PT Defined
    194           Q:$G(PT(0))="" ""
    195           N NAME S NAME=$P(PT(0),"^",1)
    196           D NAMECOMP^XLFNAME(.NAME)
    197           Q NAME("MIDDLE")
    198           ;
    199 SUFFIX() ; Suffi Name; PUBLIC; Extrinsic
    200           ; PREREQ: PT Defined
    201           Q:$G(PT(0))="" ""
    202           N NAME S NAME=$P(PT(0),"^",1)
    203           D NAMECOMP^XLFNAME(.NAME)
    204           Q NAME("SUFFIX")
    205           ;
    206 DISPNAME() ; Display Name; PUBLIC; Extrinsic
    207           ; PREREQ: PT Defined
    208           Q:$G(PT(0))="" ""
    209           N NAME S NAME=$P(PT(0),"^",1)
    210           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    211           ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    212 DOB() ; Date of Birth; PUBLIC; Extrinsic
    213           ; PREREQ: PT Defined
    214           Q:$G(PT(0))="" ""
    215           N DOB S DOB=$P(PT(0),"^",3)
    216           ; Date in FM Date Format. Convert to UTC/ISO 8601.
    217           Q $$FMDTOUTC^CCRUTIL(DOB,"D")
    218           ;
    219 GENDER() ; Get Gender; PUBLIC; Extrinsic
    220           ; PREREQ: PT Defined
    221           Q:$G(PT(0))="" ""
    222           Q $P(PT(0),"^",2)
    223           ;
    224 SSN() ; Get SSN for ID; PUBLIC; Extrinsic
    225           ; PREREQ: PT Defined
    226           Q:$G(PT(0))="" ""
    227           Q $P(PT(0),"^",9)
    228           ;
    229 ADDRTYPE() ; Get Home Address; PUBLIC; Extrinsic
    230           ; Vista only stores a home address for the patient.
    231           Q:$G(PT(0))="" ""
    232           Q "Home"
    233           ;
    234 ADDR1() ; Get Home Address line 1; PUBLIC; Extrinsic
    235           ; PREREQ: PT Defined
    236           Q:$G(PT(.11))="" ""
    237           Q $P(PT(.11),"^",1)
    238           ;
    239 ADDR2() ; Get Home Address line 2; PUBLIC; Extrinsic
    240           ; PREREQ: PT Defined
    241           ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
    242           Q:$G(PT(.11))="" ""
    243           ; If the thrid address is empty, just return the 2nd.
    244           ; If the 2nd is empty, we don't lose, b/c it will return ""
    245           ; This is so that we won't produce a comma if there is no 3rd addr.
    246           Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2)
    247           Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3)
    248           ;
    249 CITY() ; Get City for Home Address; PUBLIC; Extrinsic
    250           ; PREREQ: PT Defined
    251           Q:$G(PT(.11))="" ""
    252           Q $P(PT(.11),"^",4)
    253           ;
    254 STATE() ; Get State for Home Address; PUBLIC; Extrinsic
    255           ; PREREQ: PT Defined
    256           Q:$G(PT(.11))="" ""
    257           ; State is stored as a pointer
    258           N STATENUM S STATENUM=$P(PT(.11),"^",5)
    259           ;
    260           ; State File Global is below
    261           ; ^DIC(5,D0,0)= (#.01) NAME [1] ^ (#1) ABBREVIATION [2F] ^ (#2) VA STATE CODE
    262           ; ==>[3F] ^ (#5) CAPITAL [4F] ^ (#2.1) AAC RECOGNIZED [5S] ^ (#2.2)
    263           ; ==>US STATE OR POSSESSION [6S] ^
    264           Q:STATENUM="" ""  ; To prevent global undefined below if no state
    265           Q $P(^DIC(5,STATENUM,0),"^",1)
    266           ;
    267 ZIP() ; Get Zip code for Home Address; PUBLIC; Extrinsic
    268           ; PREREQ: PT Defined
    269           Q:$G(PT(.11))="" ""
    270           Q $P(PT(.11),"^",6)
    271           ;
    272 COUNTY() ; Get County for our Address; PUBLIC; Extrinsic
    273           ; PREREQ: PT Defined
    274           Q:$G(PT(.11))="" ""
    275           Q $P(PT(.11),"^",7)
    276           ;
    277 COUNTRY() ; Get Country for our Address; PUBLIC; Extrinsic
    278           ; Unfortunately, I can't find where that is stored, so the inevitable...
    279           Q:$G(PT(.11))="" ""
    280           Q "USA"
    281           ;
    282 RESTEL() ; Residential Telephone; PUBLIC; Extrinsic
    283           ; PREREQ: PT Defined
    284           Q:$G(PT(.13))="" ""
    285           Q $P(PT(.13),"^",1)
    286           ;
    287 WORKTEL() ; Work Telephone; PUBLIC; Extrinsic
    288           ; PREREQ: PT Defined
    289           Q:$G(PT(.13))="" ""
    290           Q $P(PT(.13),"^",2)
    291           ;
    292 EMAIL() ; Email Adddress; PUBLIC; Extrinsic
    293           ; PREREQ: PT Defined
    294           Q:$G(PT(.13))="" ""
    295           Q $P(PT(.13),"^",3)
    296           ;
    297 CELLTEL() ; Cell Phone; PUBLIC; Extrinsic
    298           ; PREREQ: PT Defined
    299           Q:$G(PT(.13))="" ""
    300           Q $P(PT(.13),"^",4)
    301           ;
    302 NOK1FAM() ; Next of Kin 1 (NOK1) Family Name; PUBLIC; Extrinsic
    303           ; PREREQ: PT Defined
    304           Q:$G(PT(.21))="" ""
    305           N NAME S NAME=$P(PT(.21),"^",1)
    306           D NAMECOMP^XLFNAME(.NAME)
    307           Q NAME("FAMILY")
    308           ;
    309 NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic
    310           ; PREREQ: PT Defined
    311           Q:$G(PT(.21))="" ""
    312           N NAME S NAME=$P(PT(.21),"^",1)
    313           D NAMECOMP^XLFNAME(.NAME)
    314           Q NAME("GIVEN")
    315           ;
    316 NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
    317           ; PREREQ: PT Defined
    318           Q:$G(PT(.21))="" ""
    319           N NAME S NAME=$P(PT(.21),"^",1)
    320           D NAMECOMP^XLFNAME(.NAME)
    321           Q NAME("MIDDLE")
    322           ;
    323 NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic
    324           ; PREREQ: PT Defined
    325           Q:$G(PT(.21))="" ""
    326           N NAME S NAME=$P(PT(.21),"^",1)
    327           D NAMECOMP^XLFNAME(.NAME)
    328           Q NAME("SUFFIX")
    329           ;
    330 NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic
    331           ; PREREQ: PT Defined
    332           Q:$G(PT(.21))="" ""
    333           N NAME S NAME=$P(PT(.21),"^",1)
    334           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    335           ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    336 NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic
    337           ; PREREQ: PT Defined
    338           Q:$G(PT(.21))="" ""
    339           Q $P(PT(.21),"^",2)
    340           ;
    341 NOK1ADD1() ; NOK1 Address 1; PUBLIC; Extrinsic
    342           ; PREREQ: PT Defined
    343           Q:$G(PT(.21))="" ""
    344           Q $P(PT(.21),"^",3)
    345           ;
    346 NOK1ADD2() ; NOK1 Address 2; PUBLIC; Extrinsic
    347           ; PREREQ: PT Defined
    348           ; As before, CCR only allows two fileds for the address, so we have to compromise
    349           Q:$G(PT(.21))="" ""
    350           ; If the thrid address is empty, just return the 2nd.
    351           ; If the 2nd is empty, we don't lose, b/c it will return ""
    352           ; This is so that we won't produce a comma if there is no 3rd addr.
    353           Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4)
    354           Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5)
    355           ;
    356 NOK1CITY() ; NOK1 City; PUBLIC; Extrinsic
    357           ; PREREQ: PT Defined
    358           Q:$G(PT(.21))="" ""
    359           Q $P(PT(.21),"^",6)
    360           ;
    361 NOK1STAT() ; NOK1 State; PUBLIC; Extrinsic
    362           ; PREREQ: PT Defined
    363           Q:$G(PT(.21))="" ""
    364           N STATENUM S STATENUM=$P(PT(.21),"^",7)
    365           Q:STATENUM="" ""
    366           Q $P(^DIC(5,STATENUM,0),"^",1)
    367           ;
    368 NOK1ZIP() ; NOK1 Zip Code; PUBLIC; Extrinsic
    369           ; PREREQ: PT Defined
    370           Q:$G(PT(.21))="" ""
    371           Q $P(PT(.21),"^",8)
    372           ;
    373 NOK1HTEL() ; NOK1 Home Telephone; PUBLIC; Extrinsic
    374           ; PREREQ: PT Defined
    375           Q:$G(PT(.21))="" ""
    376           Q $P(PT(.21),"^",9)
    377           ;
    378 NOK1WTEL() ; NOK1 Work Telephone; PUBLIC; Extrinsic
    379           ; PREREQ: PT Defined
    380           Q:$G(PT(.21))="" ""
    381           Q $P(PT(.21),"^",11)
    382           ;
    383 NOK1SAME() ; Is NOK1's Address the same the patient?; PUBLIC; Extrinsic
    384           ; PREREQ: PT Defined
    385           Q:$G(PT(.21))="" ""
    386           Q $P(PT(.21),"^",10)
    387           ;
    388 NOK2FAM() ; NOK2 Family Name; PUBLIC; Extrinsic
    389           ; PREREQ: PT Defined
    390           Q:$G(PT(.211))="" ""
    391           N NAME S NAME=$P(PT(.211),"^",1)
    392           D NAMECOMP^XLFNAME(.NAME)
    393           Q NAME("FAMILY")
    394           ;
    395 NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined
    396           Q:$G(PT(.211))="" ""
    397           N NAME S NAME=$P(PT(.211),"^",1)
    398           D NAMECOMP^XLFNAME(.NAME)
    399           Q NAME("GIVEN")
    400           ;
    401 NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
    402           ; PREREQ: PT Defined
    403           Q:$G(PT(.211))="" ""
    404           N NAME S NAME=$P(PT(.211),"^",1)
    405           D NAMECOMP^XLFNAME(.NAME)
    406           Q NAME("MIDDLE")
    407           ;
    408 NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic
    409           ; PREREQ: PT Defined
    410           Q:$G(PT(.211))="" ""
    411           N NAME S NAME=$P(PT(.211),"^",1)
    412           D NAMECOMP^XLFNAME(.NAME)
    413           Q NAME("SUFFIX")
    414 NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic
    415           ; PREREQ: PT Defined
    416           Q:$G(PT(.211))="" ""
    417           N NAME S NAME=$P(PT(.211),"^",1)
    418           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    419           ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    420 NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic
    421           ; PREREQ: PT Defined
    422           Q:$G(PT(.211))="" ""
    423           Q $P(PT(.211),"^",2)
    424           ;
    425 NOK2ADD1() ; NOK2 Address 1; PUBLIC; Extrinsic
    426           ; PREREQ: PT Defined
    427           Q:$G(PT(.211))="" ""
    428           Q $P(PT(.211),"^",3)
    429           ;
    430 NOK2ADD2() ; NOK2 Address 2; PUBLIC; Extrinsic
    431           ; PREREQ: PT Defined
    432           ; As before, CCR only allows two fileds for the address, so we have to compromise
    433           Q:$G(PT(.211))="" ""
    434           ; If the thrid address is empty, just return the 2nd.
    435           ; If the 2nd is empty, we don't lose, b/c it will return ""
    436           ; This is so that we won't produce a comma if there is no 3rd addr.
    437           Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4)
    438           Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5)
    439           ;
    440 NOK2CITY() ; NOK2 City; PUBLIC; Extrinsic
    441           ; PREREQ: PT Defined
    442           Q:$G(PT(.211))="" ""
    443           Q $P(PT(.211),"^",6)
    444           ;
    445 NOK2STAT() ; NOK2 State; PUBLIC; Extrinsic
    446           ; PREREQ: PT Defined
    447           Q:$G(PT(.211))="" ""
    448           N STATENUM S STATENUM=$P(PT(.211),"^",7)
    449           Q:STATENUM="" ""  ; To prevent global undefined below if no state
    450           Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    451           ;
    452 NOK2ZIP() ; NOK2 Zip Code; PUBLIC; Extrinsic
    453           ; PREREQ: PT Defined
    454           Q:$G(PT(.211))="" ""
    455           Q $P(PT(.211),"^",8)
    456           ;
    457 NOK2HTEL() ; NOK2 Home Telephone; PUBLIC; Extrinsic
    458           ; PREREQ: PT Defined
    459           Q:$G(PT(.211))="" ""
    460           Q $P(PT(.211),"^",9)
    461           ;
    462 NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic
    463           ; PREREQ: PT Defined
    464           Q:$G(PT(.211))="" ""
    465           Q $P(PT(.211),"^",11)
    466           ;
    467 NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic
    468           ; PREREQ: PT Defined
    469           Q:$G(PT(.211))="" ""
    470           Q $P(PT(.211),"^",10)
    471           ;
    472 EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic
    473           ; PREREQ: PT Defined
    474           Q:$G(PT(.33))="" ""
    475           N NAME S NAME=$P(PT(.33),"^",1)
    476           D NAMECOMP^XLFNAME(.NAME)
    477           Q NAME("FAMILY")
    478           ;
    479 EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic
    480           ; PREREQ: PT Defined
    481           Q:$G(PT(.33))="" ""
    482           N NAME S NAME=$P(PT(.33),"^",1)
    483           D NAMECOMP^XLFNAME(.NAME)
    484           Q NAME("GIVEN")
    485           ;
    486 EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
    487           ; PREREQ: PT Defined
    488           Q:$G(PT(.33))="" ""
    489           N NAME S NAME=$P(PT(.33),"^",1)
    490           D NAMECOMP^XLFNAME(.NAME)
    491           Q NAME("MIDDLE")
    492           ;
    493 EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic
    494           ; PREREQ: PT Defined
    495           Q:$G(PT(.33))="" ""
    496           N NAME S NAME=$P(PT(.33),"^",1)
    497           D NAMECOMP^XLFNAME(.NAME)
    498           Q NAME("SUFFIX")
    499 EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic
    500           ; PREREQ: PT Defined
    501           Q:$G(PT(.33))="" ""
    502           N NAME S NAME=$P(PT(.33),"^",1)
    503           Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    504           ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    505 EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic
    506           ; PREREQ: PT Defined
    507           Q:$G(PT(.33))="" ""
    508           Q $P(PT(.33),"^",2)
    509           ;
    510 EMERADD1() ; EMER Address 1; PUBLIC; Extrinsic
    511           ; PREREQ: PT Defined
    512           Q:$G(PT(.33))="" ""
    513           Q $P(PT(.33),"^",3)
    514           ;
    515 EMERADD2() ; EMER Address 2; PUBLIC; Extrinsic
    516           ; PREREQ: PT Defined
    517           ; As before, CCR only allows two fileds for the address, so we have to compromise
    518           Q:$G(PT(.33))="" ""
    519           ; If the thrid address is empty, just return the 2nd.
    520           ; If the 2nd is empty, we don't lose, b/c it will return ""
    521           ; This is so that we won't produce a comma if there is no 3rd addr.
    522           Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4)
    523           Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5)
    524           ;
    525 EMERCITY() ; EMER City; PUBLIC; Extrinsic
    526           ; PREREQ: PT Defined
    527           Q:$G(PT(.33))="" ""
    528           Q $P(PT(.33),"^",6)
    529           ;
    530 EMERSTAT() ; EMER State; PUBLIC; Extrinsic
    531           ; PREREQ: PT Defined
    532           Q:$G(PT(.33))="" ""
    533           N STATENUM S STATENUM=$P(PT(.33),"^",7)
    534           Q:STATENUM="" ""  ; To prevent global undefined below if no state
    535           Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    536           ;
    537 EMERZIP() ; EMER Zip Code; PUBLIC; Extrinsic
    538           ; PREREQ: PT Defined
    539           Q:$G(PT(.33))="" ""
    540           Q $P(PT(.33),"^",8)
    541           ;
    542 EMERHTEL() ; EMER Home Telephone; PUBLIC; Extrinsic
    543           ; PREREQ: PT Defined
    544           Q:$G(PT(.33))="" ""
    545           Q $P(PT(.33),"^",9)
    546           ;
    547 EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic
    548           ; PREREQ: PT Defined
    549           Q:$G(PT(.33))="" ""
    550           Q $P(PT(.33),"^",11)
    551           ;
    552 EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic
    553           ; PREREQ: PT Defined
    554           Q:$G(PT(.33))="" ""
    555           Q $P(PT(.33),"^",10)
    556           ;
     1CCRDPT ;WV/CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
     2 ;;0.2;CCRCCD;;Jun 15, 2008;
     3 ;
     4 ; Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
     5 ; General Public License.
     6 ;
     7 ; This program is distributed in the hope that it will be useful,
     8 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
     9 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     10 ; GNU General Public License for more details.
     11 ;
     12 ; You should have received a copy of the GNU General Public License along
     13 ; with this program; if not, write to the Free Software Foundation, Inc.,
     14 ; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
     15 ;
     16 ; CCRDPT       CCRCCD/SMH - Routines to Extract Patient Data for
     17 ; FAMILY       Family Name
     18 ; GIVEN        Given Name
     19 ; MIDDLE       Middle Name
     20 ; SUFFIX       Suffix Name
     21 ; DISPNAME     Display Name
     22 ; DOB          Date of Birth
     23 ; GENDER       Get Gender
     24 ; SSN          Get SSN for ID
     25 ; ADDRTYPE     Get Home Address
     26 ; ADDR1        Get Home Address line 1
     27 ; ADDR2        Get Home Address line 2
     28 ; CITY         Get City for Home Address
     29 ; STATE        Get State for Home Address
     30 ; ZIP          Get Zip code for Home Address
     31 ; COUNTY       Get County for our Address
     32 ; COUNTRY      Get Country for our Address
     33 ; RESTEL       Residential Telephone
     34 ; WORKTEL      Work Telephone
     35 ; EMAIL        Email Adddress
     36 ; CELLTEL      Cell Phone
     37 ; NOK1FAM      Next of Kin 1 (NOK1) Family Name
     38 ; NOK1GIV      NOK1 Given Name
     39 ; NOK1MID      NOK1 Middle Name
     40 ; NOK1SUF      NOK1 Suffi Name
     41 ; NOK1DISP     NOK1 Display Name
     42 ; NOK1REL      NOK1 Relationship to the patient
     43 ; NOK1ADD1     NOK1 Address 1
     44 ; NOK1ADD2     NOK1 Address 2
     45 ; NOK1CITY     NOK1 City
     46 ; NOK1STAT     NOK1 State
     47 ; NOK1ZIP      NOK1 Zip Code
     48 ; NOK1HTEL     NOK1 Home Telephone
     49 ; NOK1WTEL     NOK1 Work Telephone
     50 ; NOK1SAME     Is NOK1's Address the same the patient?
     51 ; NOK2FAM      NOK2 Family Name
     52 ; NOK2GIV      NOK2 Given Name
     53 ; NOK2MID      NOK2 Middle Name
     54 ; NOK2SUF      NOK2 Suffi Name
     55 ; NOK2DISP     NOK2 Display Name
     56 ; NOK2REL      NOK2 Relationship to the patient
     57 ; NOK2ADD1     NOK2 Address 1
     58 ; NOK2ADD2     NOK2 Address 2
     59 ; NOK2CITY     NOK2 City
     60 ; NOK2STAT     NOK2 State
     61 ; NOK2ZIP      NOK2 Zip Code
     62 ; NOK2HTEL     NOK2 Home Telephone
     63 ; NOK2WTEL     NOK2 Work Telephone
     64 ; NOK2SAME     Is NOK2's Address the same the patient?
     65 ; EMERFAM      Emergency Contact (EMER) Family Name
     66 ; EMERGIV      EMER Given Name
     67 ; EMERMID      EMER Middle Name
     68 ; EMERSUF      EMER Suffi Name
     69 ; EMERDISP     EMER Display Name
     70 ; EMERREL      EMER Relationship to the patient
     71 ; EMERADD1     EMER Address 1
     72 ; EMERADD2     EMER Address 2
     73 ; EMERCITY     EMER City
     74 ; EMERSTAT     EMER State
     75 ; EMERZIP      EMER Zip Code
     76 ; EMERHTEL     EMER Home Telephone
     77 ; EMERWTEL     EMER Work Telephone
     78 ; EMERSAME     Is EMER's Address the same the NOK?
     79 ;
     80 W "No Entry at top!" Q
     81 ;
     82 ;**Revision History**
     83 ; - June 15, 08: v0.1 using merged global
     84 ; - Oct 3, 08: v0.2 using fileman calls, many formatting changes.
     85 ;
     86 ; All methods are Public and Extrinsic
     87 ; All calls use Fileman file 2 (Patient).
     88 ; You can obtain field numbers using the data dictionary
     89 ;
     90FAMILY(DFN) ; Family Name
     91 N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     92 D NAMECOMP^XLFNAME(.NAME)
     93 Q NAME("FAMILY")
     94GIVEN(DFN) ; Given Name
     95 N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     96 D NAMECOMP^XLFNAME(.NAME)
     97 Q NAME("GIVEN")
     98MIDDLE(DFN) ; Middle Name
     99 N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     100 D NAMECOMP^XLFNAME(.NAME)
     101 Q NAME("MIDDLE")
     102SUFFIX(DFN) ; Suffi Name
     103 N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     104 D NAMECOMP^XLFNAME(.NAME)
     105 Q NAME("SUFFIX")
     106DISPNAME(DFN) ; Display Name
     107 N NAME S NAME=$$GET1^DIQ(2,DFN,.01)
     108 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     109 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     110DOB(DFN) ; Date of Birth
     111 N DOB S DOB=$$GET1^DIQ(2,DFN,.03,"I")
     112 ; Date in FM Date Format. Convert to UTC/ISO 8601.
     113 Q $$FMDTOUTC^CCRUTIL(DOB,"D")
     114GENDER(DFN) ; Gender/Sex
     115 Q $$GET1^DIQ(2,DFN,.02) ;
     116SSN(DFN) ; SSN
     117 Q $$GET1^DIQ(2,DFN,.09)
     118ADDRTYPE(DFN) ; Address Type
     119 ; Vista only stores a home address for the patient.
     120 Q "Home"
     121ADDR1(DFN) ; Get Home Address line 1
     122 Q $$GET1^DIQ(2,DFN,.111)
     123ADDR2(DFN) ; Get Home Address line 2
     124 ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
     125 N ADDLN2,ADDLN3
     126 S ADDLN2=$$GET1^DIQ(2,DFN,.112),ADDLN3=$$GET1^DIQ(2,DFN,.113)
     127 Q:ADDLN3="" ADDLN2
     128 Q ADDLN2_", "_ADDLN3
     129CITY(DFN) ; Get City for Home Address
     130 Q $$GET1^DIQ(2,DFN,.114)
     131STATE(DFN) ; Get State for Home Address
     132 Q $$GET1^DIQ(2,DFN,.115)
     133ZIP(DFN) ; Get Zip code for Home Address
     134 Q $$GET1^DIQ(2,DFN,.116)
     135COUNTY(DFN) ; Get County for our Address
     136 Q $$GET1^DIQ(2,DFN,.117)
     137COUNTRY(DFN) ; Get Country for our Address
     138 ; Unfortunately, it's not stored anywhere in Vista, so the inevitable...
     139 Q "USA"
     140RESTEL(DFN) ; Residential Telephone
     141 Q $$GET1^DIQ(2,DFN,.131)
     142WORKTEL(DFN) ; Work Telephone
     143 Q $$GET1^DIQ(2,DFN,.132)
     144EMAIL(DFN) ; Email Adddress
     145 Q $$GET1^DIQ(2,DFN,.133)
     146CELLTEL(DFN) ; Cell Phone
     147 Q $$GET1^DIQ(2,DFN,.134)
     148NOK1FAM(DFN) ; Next of Kin 1 (NOK1) Family Name
     149 N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     150 D NAMECOMP^XLFNAME(.NAME)
     151 Q NAME("FAMILY")
     152NOK1GIV(DFN) ; NOK1 Given Name
     153 N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     154 D NAMECOMP^XLFNAME(.NAME)
     155 Q NAME("GIVEN")
     156NOK1MID(DFN) ; NOK1 Middle Name
     157 N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     158 D NAMECOMP^XLFNAME(.NAME)
     159 Q NAME("MIDDLE")
     160NOK1SUF(DFN) ; NOK1 Suffi Name
     161 N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     162 D NAMECOMP^XLFNAME(.NAME)
     163 Q NAME("SUFFIX")
     164NOK1DISP(DFN) ; NOK1 Display Name
     165 N NAME S NAME=$$GET1^DIQ(2,DFN,.211)
     166 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     167 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     168NOK1REL(DFN) ; NOK1 Relationship to the patient
     169 Q $$GET1^DIQ(2,DFN,.212)
     170NOK1ADD1(DFN) ; NOK1 Address 1
     171 Q $$GET1^DIQ(2,DFN,.213)
     172NOK1ADD2(DFN) ; NOK1 Address 2
     173 N ADDLN2,ADDLN3
     174 S ADDLN2=$$GET1^DIQ(2,DFN,.214),ADDLN3=$$GET1^DIQ(2,DFN,.215)
     175 Q:ADDLN3="" ADDLN2
     176 Q ADDLN2_", "_ADDLN3
     177NOK1CITY(DFN) ; NOK1 City
     178 Q $$GET1^DIQ(2,DFN,.216)
     179NOK1STAT(DFN) ; NOK1 State
     180 Q $$GET1^DIQ(2,DFN,.217)
     181NOK1ZIP(DFN) ; NOK1 Zip Code
     182 Q $$GET1^DIQ(2,DFN,.218)
     183NOK1HTEL(DFN) ; NOK1 Home Telephone
     184 Q $$GET1^DIQ(2,DFN,.219)
     185NOK1WTEL(DFN) ; NOK1 Work Telephone
     186 Q $$GET1^DIQ(2,DFN,.21011)
     187NOK1SAME(DFN) ; Is NOK1's Address the same the patient?
     188 Q $$GET1^DIQ(2,DFN,.2125)
     189NOK2FAM(DFN) ; NOK2 Family Name
     190 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     191 D NAMECOMP^XLFNAME(.NAME)
     192 Q NAME("FAMILY")
     193NOK2GIV(DFN) ; NOK2 Given Name
     194 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     195 D NAMECOMP^XLFNAME(.NAME)
     196 Q NAME("GIVEN")
     197NOK2MID(DFN) ; NOK2 Middle Name
     198 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     199 D NAMECOMP^XLFNAME(.NAME)
     200 Q NAME("MIDDLE")
     201NOK2SUF(DFN) ; NOK2 Suffi Name
     202 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     203 D NAMECOMP^XLFNAME(.NAME)
     204 Q NAME("SUFFIX")
     205NOK2DISP(DFN) ; NOK2 Display Name
     206 N NAME S NAME=$$GET1^DIQ(2,DFN,.2191)
     207 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     208 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     209NOK2REL(DFN) ; NOK2 Relationship to the patient
     210 Q $$GET1^DIQ(2,DFN,.2192)
     211NOK2ADD1(DFN) ; NOK2 Address 1
     212 Q $$GET1^DIQ(2,DFN,.2193)
     213NOK2ADD2(DFN) ; NOK2 Address 2
     214 N ADDLN2,ADDLN3
     215 S ADDLN2=$$GET1^DIQ(2,DFN,.2194),ADDLN3=$$GET1^DIQ(2,DFN,.2195)
     216 Q:ADDLN3="" ADDLN2
     217 Q ADDLN2_", "_ADDLN3
     218NOK2CITY(DFN) ; NOK2 City
     219 Q $$GET1^DIQ(2,DFN,.2196)
     220NOK2STAT(DFN) ; NOK2 State
     221 Q $$GET1^DIQ(2,DFN,.2197)
     222NOK2ZIP(DFN) ; NOK2 Zip Code
     223 Q $$GET1^DIQ(2,DFN,.2198)
     224NOK2HTEL(DFN) ; NOK2 Home Telephone
     225 Q $$GET1^DIQ(2,DFN,.2199)
     226NOK2WTEL(DFN) ; NOK2 Work Telephone
     227 Q $$GET1^DIQ(2,DFN,.211011)
     228NOK2SAME(DFN) ; Is NOK2's Address the same the patient?
     229 Q $$GET1^DIQ(2,DFN,.21925)
     230EMERFAM(DFN) ; Emergency Contact (EMER) Family Name
     231 N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     232 D NAMECOMP^XLFNAME(.NAME)
     233 Q NAME("FAMILY")
     234EMERGIV(DFN) ; EMER Given Name
     235 N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     236 D NAMECOMP^XLFNAME(.NAME)
     237 Q NAME("GIVEN")
     238EMERMID(DFN) ; EMER Middle Name
     239 N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     240 D NAMECOMP^XLFNAME(.NAME)
     241 Q NAME("MIDDLE")
     242EMERSUF(DFN) ; EMER Suffi Name
     243 N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     244 D NAMECOMP^XLFNAME(.NAME)
     245 Q NAME("SUFFIX")
     246EMERDISP(DFN) ; EMER Display Name
     247 N NAME S NAME=$$GET1^DIQ(2,DFN,.331)
     248 ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     249 Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     250EMERREL(DFN) ; EMER Relationship to the patient
     251 Q $$GET1^DIQ(2,DFN,.331)
     252EMERADD1(DFN) ; EMER Address 1
     253 Q $$GET1^DIQ(2,DFN,.333)
     254EMERADD2(DFN) ; EMER Address 2
     255 N ADDLN2,ADDLN3
     256 S ADDLN2=$$GET1^DIQ(2,DFN,.334),ADDLN3=$$GET1^DIQ(2,DFN,.335)
     257 Q:ADDLN3="" ADDLN2
     258 Q ADDLN2_", "_ADDLN3
     259EMERCITY(DFN) ; EMER City
     260 Q $$GET1^DIQ(2,DFN,.336)
     261EMERSTAT(DFN) ; EMER State
     262 Q $$GET1^DIQ(2,DFN,.337)
     263EMERZIP(DFN) ; EMER Zip Code
     264 Q $$GET1^DIQ(2,DFN,.338)
     265EMERHTEL(DFN) ; EMER Home Telephone
     266 Q $$GET1^DIQ(2,DFN,.339)
     267EMERWTEL(DFN) ; EMER Work Telephone
     268 Q $$GET1^DIQ(2,DFN,.33011)
     269EMERSAME(DFN) ; Is EMER's Address the same the NOK?
     270 Q $$GET1^DIQ(2,DFN,.3305)

  • ccr/trunk/p/CCRDPTT.m

    r122 r175  
    3636          ;
    3737          W "You have selected patient "_Y,!!
    38           D INIT^CCRDPT($P(Y,"^"))
    39           ; ZWR PT
    40           N I S I=165 F  S I=$O(OUT(I)) Q:I=""  D
     38          N I S I=89 F  S I=$O(OUT(I)) Q:I="ALINE"  D
    4139          . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
    4240          . W "valued at "
    43           . W @("$$"_$P(OUT(I,0),"()")_"^"_"CCRDPT"_"()")
     41                  . W @("$$"_$P(OUT(I,0),"(DFN)")_"^"_"CCRDPT"_"("_$P(Y,"^")_")")
    4442          . W !
    4543          Q

  • ccr/trunk/p/CCRUNIT.m

    r173 r175  
    1414        W "QUERY^GPLXPATH(T,XPATH,""MINXML"")",!!
    1515        D QUERY^GPLXPATH(T,XPATH,"MINXML")
    16         B
    1716                W "Executing EXTRACT^CCRMEDS(MINXML,DFN,OUTXML)",!
    1817        W "OUTXML will be ^TMP($J,""OUT"")",!
    1918        N OUTXML S OUTXML=$NA(^TMP($J,"OUT"))
    20         D EXTRACT^CCRMEDS("MINXML",DFN,OUTXML)
     19        D EXTRACT^CCRMEDS($NA(MINXML),DFN,OUTXML)
    2120        Q

  • ccr/trunk/p/GPLACTOR.m

    r141 r175  
    11GPLACTOR  ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2  ;;0.3;CCDCCR;nopatch;noreleasedate
    3  ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    4  ;General Public License See attached copy of the License.
     2 ;;0.4;CCDCCR;nopatch;noreleasedate
     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.
    519 ;
    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.
     20 ;  PROCESS THE ACTORS SECTION OF THE CCR
    1021 ;
    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.
     22 ; ===Revision History===
     23 ; 0.1 Initial Writing of Skeleton--GPL
     24 ; 0.2 Patient Data Extraction--SMH
     25 ; 0.3 Information System Info Extraction--SMH
     26 ; 0.4 Patient data rouine refactored; adjustments here--SMH
    1527 ;
    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     ;  PROCESS THE ACTORS SECTION OF THE CCR
    21     ;
    22     ; ===Revision History===
    23     ; 0.1 Initial Writing of Skeleton--GPL
    24     ; 0.2 Patient Data Extraction--SMH
    25     ; 0.3 Information System Info Extraction--SMH
    26     ;
    2728EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
    28   ; IPXML is the Input Actor Template into which we  substitute values
    29   ; This is straight XML. Values to be substituted are in @@VAL@@ format.
    30   ; ALST is the actor list global generated by ACTLST^GPLCCR and has format:
    31   ; ^TMP(7542,1,"ACTORS",0)=Count
    32   ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
    33   ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
    34   ; AXML is the output arrary, to contain XML.
    35   ;
    36            N I,J,AMAP,AOID,ATYP,AIEN
    37            D CP^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
    38            D REPLACE^GPLXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
    39            I DEBUG W "PROCESSING ACTORS ",!
    40            F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
    41            . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
    42            . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
    43            . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
    44            . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
    45            . I ATYP="" Q  ; NOT A VALID ACTOR
    46            . ;
    47            . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
    48            . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
    49            . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
    50            . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
    51            . ;
    52            . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
    53            . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
    54            . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
    55            . ;
    56            . I ATYP="NOK" D  ; NOK ACTOR TYPE
    57            . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
    58            . . D NOK("ATMP",AIEN,AOID,"ATMP2")
    59            . ;
    60            . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
    61            . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
    62            . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
    63            . ;
    64            . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
    65            . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
    66            . . D ORG("ATMP",AIEN,AOID,"ATMP2")
    67            . ;
    68            . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
    69            ;
    70            N ACTTMP
    71            D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
    72            I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
    73            . ; STRINGS MARKED AS @@X@@
    74            . W "ACTORS Missing list: ",!
    75            . F I=1:1:ACTTMP(0) W ACTTMP(I),!
    76            Q
    77            ;
     29 ; IPXML is the Input Actor Template into which we  substitute values
     30 ; This is straight XML. Values to be substituted are in @@VAL@@ format.
     31 ; ALST is the actor list global generated by ACTLST^GPLCCR and has format:
     32 ; ^TMP(7542,1,"ACTORS",0)=Count
     33 ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
     34 ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
     35 ; AXML is the output arrary, to contain XML.
     36 ;
     37 N I,J,AMAP,AOID,ATYP,AIEN
     38 D CP^GPLXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
     39 D REPLACE^GPLXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
     40 I DEBUG W "PROCESSING ACTORS ",!
     41 F I=1:1:@ALST@(0) D  ; PROCESS ALL ACTORS IN THE LIST
     42 . I @ALST@(I)["@@" Q  ; NOT A VALID ACTOR
     43 . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
     44 . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
     45 . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
     46 . I ATYP="" Q  ; NOT A VALID ACTOR
     47 . ;
     48 . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
     49 . I ATYP="PATIENT" D  ; PATIENT ACTOR TYPE
     50 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
     51 . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
     52 . ;
     53 . I ATYP="SYSTEM" D  ; SYSTEM ACTOR TYPE
     54 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
     55 . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
     56 . ;
     57 . I ATYP="NOK" D  ; NOK ACTOR TYPE
     58 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
     59 . . D NOK("ATMP",AIEN,AOID,"ATMP2")
     60 . ;
     61 . I ATYP="PROVIDER" D  ; PROVIDER ACTOR TYPE
     62 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
     63 . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
     64 . ;
     65 . I ATYP="ORGANIZATION" D  ; PROVIDER ACTOR TYPE
     66 . . D QUERY^GPLXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
     67 . . D ORG("ATMP",AIEN,AOID,"ATMP2")
     68 . ;
     69 . D INSINNER^GPLXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
     70 ;
     71 N ACTTMP
     72 D MISSING^GPLXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
     73 I ACTTMP(0)>0  D  ; IF THERE ARE MISSING VARS -
     74 . ; STRINGS MARKED AS @@X@@
     75 . W "ACTORS Missing list: ",!
     76 . F I=1:1:ACTTMP(0) W ACTTMP(I),!
     77 Q
     78 ;
    7879PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
    79      ;
    80      I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
    81      N AMAP,ZX
    82      S AMAP=$NA(^TMP($J,"AMAP"))
    83      K @AMAP
    84      D INIT^CCRDPT(AIEN)
    85      S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
    86      S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT
    87      S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT
    88      S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT
    89      S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT
    90      S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT
    91      S @AMAP@("ACTORSSN")=""
    92      S @AMAP@("ACTORSSNTEXT")=""
    93      S @AMAP@("ACTORSSNSOURCEID")=""
    94      S ZX=$$SSN^CCRDPT
    95      I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
    96      . S @AMAP@("ACTORSSN")=ZX
    97      . S @AMAP@("ACTORSSNTEXT")="SSN"
    98      . S @AMAP@("ACTORSSNSOURCEID")=AOID
    99      S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT
    100      S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT
    101      S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT
    102      S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT
    103      S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT
    104      S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT
    105      S @AMAP@("ACTORRESTEL")=""
    106      S @AMAP@("ACTORRESTELTEXT")=""
    107      S ZX=$$RESTEL^CCRDPT
    108      I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    109      . S @AMAP@("ACTORRESTEL")=ZX
    110      . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
    111      S @AMAP@("ACTORWORKTEL")=""
    112      S @AMAP@("ACTORWORKTELTEXT")=""
    113      S ZX=$$WORKTEL^CCRDPT
    114      I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
    115      . S @AMAP@("ACTORWORKTEL")=ZX
    116      . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
    117      S @AMAP@("ACTORCELLTEL")=""
    118      S @AMAP@("ACTORCELLTELTEXT")=""
    119      S ZX=$$CELLTEL^CCRDPT
    120      I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
    121      . S @AMAP@("ACTORCELLTEL")=ZX
    122      . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
    123      S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT
    124      S @AMAP@("ACTORADDRESSSOURCEID")=AOID
    125      S @AMAP@("ACTORIEN")=AIEN
    126      S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
    127      S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
    128          D DESTROY^CCRDPT
    129      D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
    130      Q
    131      ;
     80 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
     81 N AMAP,ZX
     82 S AMAP=$NA(^TMP($J,"AMAP"))
     83 K @AMAP
     84 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
     85 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^CCRDPT(AIEN)
     86 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^CCRDPT(AIEN)
     87 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^CCRDPT(AIEN)
     88 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^CCRDPT(AIEN)
     89 S @AMAP@("ACTORGENDER")=$$GENDER^CCRDPT(AIEN)
     90 S @AMAP@("ACTORSSN")=""
     91 S @AMAP@("ACTORSSNTEXT")=""
     92 S @AMAP@("ACTORSSNSOURCEID")=""
     93 S ZX=$$SSN^CCRDPT(AIEN)
     94 I ZX'="" D  ; IF THERE IS A SSN IN THE RECORD
     95 . S @AMAP@("ACTORSSN")=ZX
     96 . S @AMAP@("ACTORSSNTEXT")="SSN"
     97 . S @AMAP@("ACTORSSNSOURCEID")=AOID
     98 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^CCRDPT(AIEN)
     99 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^CCRDPT(AIEN)
     100 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^CCRDPT(AIEN)
     101 S @AMAP@("ACTORADDRESSCITY")=$$CITY^CCRDPT(AIEN)
     102 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^CCRDPT(AIEN)
     103 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^CCRDPT(AIEN)
     104 S @AMAP@("ACTORRESTEL")=""
     105 S @AMAP@("ACTORRESTELTEXT")=""
     106 S ZX=$$RESTEL^CCRDPT(AIEN)
     107 I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     108 . S @AMAP@("ACTORRESTEL")=ZX
     109 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
     110 S @AMAP@("ACTORWORKTEL")=""
     111 S @AMAP@("ACTORWORKTELTEXT")=""
     112 S ZX=$$WORKTEL^CCRDPT(AIEN)
     113 I ZX'="" D  ; IF THERE IS A RESIDENT PHONE IN THE RECORD
     114 . S @AMAP@("ACTORWORKTEL")=ZX
     115 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
     116 S @AMAP@("ACTORCELLTEL")=""
     117 S @AMAP@("ACTORCELLTELTEXT")=""
     118 S ZX=$$CELLTEL^CCRDPT(AIEN)
     119 I ZX'="" D  ; IF THERE IS A CELL PHONE IN THE RECORD
     120 . S @AMAP@("ACTORCELLTEL")=ZX
     121 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
     122 S @AMAP@("ACTOREMAIL")=$$EMAIL^CCRDPT(AIEN)
     123 S @AMAP@("ACTORADDRESSSOURCEID")=AOID
     124 S @AMAP@("ACTORIEN")=AIEN
     125 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
     126 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
     127 D MAP^GPLXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
     128 Q
     129 ;
    132130SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
    133131     ;
Note: See TracChangeset for help on using the changeset viewer.