Changeset 40


Ignore:
Timestamp:
Jul 3, 2008, 9:02:47 PM (16 years ago)
Author:
Christopher Edwards
Message:

fixed spacing issues

Location:
ccr/trunk/p
Files:
9 edited

Legend:

Unmodified
Added
Removed

  • ccr/trunk/p/CCRDPT.m

    r26 r40  
    11CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08
    2         ;;0.1;CCRCCD;;Jun 15, 2008;
    3 
    4         ;       NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
    5         ;       DESTROY to clean-up.
    6 
    7         ;       The first line of every routine tests if the global exists.
    8        
    9         ;       CCRDPT     83 lines  CCRCCD/SMH - Routines to Extract Patient Data for
    10         ;       INIT        9 lines  Copy DFN global to a local variable
    11         ;       DESTROY     6 lines  Kill local variable
    12         ;       FAMILY      6 lines  Family Name
    13         ;       GIVEN       6 lines  Given Name
    14         ;       MIDDLE      6 lines  Middle Name
    15         ;       SUFFIX      6 lines  Suffix Name       
    16         ;       DISPNAME    5 lines  Display Name
    17         ;       DOB         6 lines  Date of Birth
    18         ;       GENDER      4 lines  Get Gender
    19         ;       SSN         4 lines  Get SSN for ID
    20         ;       ADDRTYPE    4 lines  Get Home Address
    21         ;       ADDR1       4 lines  Get Home Address line 1
    22         ;       ADDR2       5 lines  Get Home Address line 2
    23         ;       CITY        4 lines  Get City for Home Address
    24         ;       STATE      11 lines  Get State for Home Address
    25         ;       ZIP         4 lines  Get Zip code for Home Address
    26         ;       COUNTY      4 lines  Get County for our Address
    27         ;       COUNTRY     4 lines  Get Country for our Address
    28         ;       RESTEL      4 lines  Residential Telephone
    29         ;       WORKTEL     4 lines  Work Telephone
    30         ;       EMAIL       4 lines  Email Adddress
    31         ;       CELLTEL     4 lines  Cell Phone
    32         ;       NOK1FAM     6 lines  Next of Kin 1 (NOK1) Family Name
    33         ;       NOK1GIV     6 lines  NOK1 Given Name
    34         ;       NOK1MID     6 lines  NOK1 Middle Name
    35         ;       NOK1SUF     6 lines  NOK1 Suffi Name
    36         ;       NOK1DISP    5 lines  NOK1 Display Name
    37         ;       NOK1REL     4 lines  NOK1 Relationship to the patient
    38         ;       NOK1ADD1    4 lines  NOK1 Address 1
    39         ;       NOK1ADD2    5 lines  NOK1 Address 2
    40         ;       NOK1CITY    4 lines  NOK1 City
    41         ;       NOK1STAT    5 lines  NOK1 State
    42         ;       NOK1ZIP     4 lines  NOK1 Zip Code
    43         ;       NOK1HTEL;   4 lines  NOK1 Home Telephone
    44         ;       NOK1WTEL;   4 lines  NOK1 Work Telephone
    45         ;       NOK1SAME;   4 lines  Is NOK1's Address the same the patient?
    46         ;       NOK2FAM     6 lines  NOK2 Family Name
    47         ;       NOK2GIV     6 lines  NOK2 Given Name
    48         ;       NOK2MID     6 lines  NOK2 Middle Name
    49         ;       NOK2SUF     5 lines  NOK2 Suffi Name
    50         ;       NOK2DISP    5 lines  NOK2 Display Name
    51         ;       NOK2REL     4 lines  NOK2 Relationship to the patient
    52         ;       NOK2ADD1    4 lines  NOK2 Address 1
    53         ;       NOK2ADD2    5 lines  NOK2 Address 2
    54         ;       NOK2CITY    4 lines  NOK2 City
    55         ;       NOK2STAT    5 lines  NOK2 State
    56         ;       NOK2ZIP     4 lines  NOK2 Zip Code
    57         ;       NOK2HTEL;   4 lines  NOK2 Home Telephone
    58         ;       NOK2WTEL;   4 lines  NOK2 Work Telephone
    59         ;       NOK2SAME;   4 lines  Is NOK2's Address the same the patient?
    60         ;       EMERFAM     6 lines  Emergency Contact (EMER) Family Name
    61         ;       EMERGIV     6 lines  EMER Given Name
    62         ;       EMERMID     6 lines  EMER Middle Name
    63         ;       EMERSUF     5 lines  EMER Suffi Name
    64         ;       EMERDISP    5 lines  EMER Display Name
    65         ;       EMERREL     4 lines  EMER Relationship to the patient
    66         ;       EMERADD1    4 lines  EMER Address 1
    67         ;       EMERADD2    5 lines  EMER Address 2
    68         ;       EMERCITY    4 lines  EMER City
    69         ;       EMERSTAT    5 lines  EMER State
    70         ;       EMERZIP     4 lines  EMER Zip Code
    71         ;       EMERHTEL;   4 lines  EMER Home Telephone
    72         ;       EMERWTEL;   4 lines  EMER Work Telephone
    73         ;       EMERSAME;   4 lines  Is EMER's Address the same the NOK?
    74 
    75         W "No Entry at top!" Q
    76        
    77         ;  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] ^
    90         ;       ^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        
     2          ;;0.1;CCRCCD;;Jun 15, 2008;
     3         
     4          ; NOTE TO PROGRAMMER: You need to call INIT(DPT) to initialize; and
     5          ; DESTROY to clean-up.
     6         
     7          ; The first line of every routine tests if the global exists.
     8         
     9          ; CCRDPT     83 lines  CCRCCD/SMH - Routines to Extract Patient Data for
     10          ; INIT        9 lines  Copy DFN global to a local variable
     11          ; DESTROY     6 lines  Kill local variable
     12          ; FAMILY      6 lines  Family Name
     13          ; GIVEN       6 lines  Given Name
     14          ; MIDDLE      6 lines  Middle Name
     15          ; SUFFIX      6 lines  Suffix Name         
     16          ; DISPNAME    5 lines  Display Name
     17          ; DOB         6 lines  Date of Birth
     18          ; GENDER      4 lines  Get Gender
     19          ; SSN         4 lines  Get SSN for ID
     20          ; ADDRTYPE    4 lines  Get Home Address
     21          ; ADDR1       4 lines  Get Home Address line 1
     22          ; ADDR2       5 lines  Get Home Address line 2
     23          ; CITY        4 lines  Get City for Home Address
     24          ; STATE      11 lines  Get State for Home Address
     25          ; ZIP         4 lines  Get Zip code for Home Address
     26          ; COUNTY      4 lines  Get County for our Address
     27          ; COUNTRY     4 lines  Get Country for our Address
     28          ; RESTEL      4 lines  Residential Telephone
     29          ; WORKTEL     4 lines  Work Telephone
     30          ; EMAIL       4 lines  Email Adddress
     31          ; CELLTEL     4 lines  Cell Phone
     32          ; NOK1FAM     6 lines  Next of Kin 1 (NOK1) Family Name
     33          ; NOK1GIV     6 lines  NOK1 Given Name
     34          ; NOK1MID     6 lines  NOK1 Middle Name
     35          ; NOK1SUF     6 lines  NOK1 Suffi Name
     36          ; NOK1DISP    5 lines  NOK1 Display Name
     37          ; NOK1REL     4 lines  NOK1 Relationship to the patient
     38          ; NOK1ADD1    4 lines  NOK1 Address 1
     39          ; NOK1ADD2    5 lines  NOK1 Address 2
     40          ; NOK1CITY    4 lines  NOK1 City
     41          ; NOK1STAT    5 lines  NOK1 State
     42          ; NOK1ZIP     4 lines  NOK1 Zip Code
     43          ; NOK1HTEL;   4 lines  NOK1 Home Telephone
     44          ; NOK1WTEL;   4 lines  NOK1 Work Telephone
     45          ; NOK1SAME;   4 lines  Is NOK1's Address the same the patient?
     46          ; NOK2FAM     6 lines  NOK2 Family Name
     47          ; NOK2GIV     6 lines  NOK2 Given Name
     48          ; NOK2MID     6 lines  NOK2 Middle Name
     49          ; NOK2SUF     5 lines  NOK2 Suffi Name
     50          ; NOK2DISP    5 lines  NOK2 Display Name
     51          ; NOK2REL     4 lines  NOK2 Relationship to the patient
     52          ; NOK2ADD1    4 lines  NOK2 Address 1
     53          ; NOK2ADD2    5 lines  NOK2 Address 2
     54          ; NOK2CITY    4 lines  NOK2 City
     55          ; NOK2STAT    5 lines  NOK2 State
     56          ; NOK2ZIP     4 lines  NOK2 Zip Code
     57          ; NOK2HTEL;   4 lines  NOK2 Home Telephone
     58          ; NOK2WTEL;   4 lines  NOK2 Work Telephone
     59          ; NOK2SAME;   4 lines  Is NOK2's Address the same the patient?
     60          ; EMERFAM     6 lines  Emergency Contact (EMER) Family Name
     61          ; EMERGIV     6 lines  EMER Given Name
     62          ; EMERMID     6 lines  EMER Middle Name
     63          ; EMERSUF     5 lines  EMER Suffi Name
     64          ; EMERDISP    5 lines  EMER Display Name
     65          ; EMERREL     4 lines  EMER Relationship to the patient
     66          ; EMERADD1    4 lines  EMER Address 1
     67          ; EMERADD2    5 lines  EMER Address 2
     68          ; EMERCITY    4 lines  EMER City
     69          ; EMERSTAT    5 lines  EMER State
     70          ; EMERZIP     4 lines  EMER Zip Code
     71          ; EMERHTEL;   4 lines  EMER Home Telephone
     72          ; EMERWTEL;   4 lines  EMER Work Telephone
     73          ; EMERSAME;   4 lines  Is EMER's Address the same the NOK?
     74         
     75          W "No Entry at top!" Q
     76         
     77          ; 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] ^
     90          ; ^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         
    152152INIT(DFN) ; Copy DFN global to a local variable; PUBLIC
    153         ; INPUT: Patient IEN (DFN)
    154         ; OUTPUT: PT in the Symbol Table, representing the patient global
    155        
    156         ; Instead of accessing a global each single read (SLOOOOW)
    157         ; read it off a local variable stored in Memory.
    158         M PT=^DPT(DFN)
    159         Q
    160         ;
     153          ; INPUT: Patient IEN (DFN)
     154          ; OUTPUT: PT in the Symbol Table, representing the patient global
     155         
     156          ; Instead of accessing a global each single read (SLOOOOW)
     157          ; read it off a local variable stored in Memory.
     158          M PT=^DPT(DFN)
     159          Q
     160          ;
    161161DESTROY ; Kill local variable; PUBLIC
    162         ; INPUT: None
    163         ; OUTPUT: Kill PT from the Symbol Table after you are done
    164         K PT
    165         Q
    166         ;
     162          ; INPUT: None
     163          ; OUTPUT: Kill PT from the Symbol Table after you are done
     164          K PT
     165          Q
     166          ;
    167167FAMILY() ; Family Name; PUBLIC; Extrinsic
    168         ; PREREQ: PT Defined
    169         Q:$G(PT(0))="" ""
    170         N NAME S NAME=$P(PT(0),"^",1)
    171         D NAMECOMP^XLFNAME(.NAME)
    172         Q NAME("FAMILY")
    173         ;
     168          ; PREREQ: PT Defined
     169          Q:$G(PT(0))="" ""
     170          N NAME S NAME=$P(PT(0),"^",1)
     171          D NAMECOMP^XLFNAME(.NAME)
     172          Q NAME("FAMILY")
     173          ;
    174174GIVEN() ; Given Name; PUBLIC; Extrinsic
    175         ; PREREQ: PT Defined
    176         Q:$G(PT(0))="" ""
    177         N NAME S NAME=$P(PT(0),"^",1)
    178         D NAMECOMP^XLFNAME(.NAME)
    179         Q NAME("GIVEN")
    180         ;
     175          ; PREREQ: PT Defined
     176          Q:$G(PT(0))="" ""
     177          N NAME S NAME=$P(PT(0),"^",1)
     178          D NAMECOMP^XLFNAME(.NAME)
     179          Q NAME("GIVEN")
     180          ;
    181181MIDDLE() ; Middle Name; PUBLIC; Extrinsic
    182         ; PREREQ: PT Defined
    183         Q:$G(PT(0))="" ""
    184         N NAME S NAME=$P(PT(0),"^",1)
    185         D NAMECOMP^XLFNAME(.NAME)
    186         Q NAME("MIDDLE")
    187         ;
     182          ; PREREQ: PT Defined
     183          Q:$G(PT(0))="" ""
     184          N NAME S NAME=$P(PT(0),"^",1)
     185          D NAMECOMP^XLFNAME(.NAME)
     186          Q NAME("MIDDLE")
     187          ;
    188188SUFFIX() ; Suffi Name; PUBLIC; Extrinsic
    189         ; PREREQ: PT Defined
    190         Q:$G(PT(0))="" ""
    191         N NAME S NAME=$P(PT(0),"^",1)
    192         D NAMECOMP^XLFNAME(.NAME)
    193         Q NAME("SUFFIX")
    194         ;
     189          ; PREREQ: PT Defined
     190          Q:$G(PT(0))="" ""
     191          N NAME S NAME=$P(PT(0),"^",1)
     192          D NAMECOMP^XLFNAME(.NAME)
     193          Q NAME("SUFFIX")
     194          ;
    195195DISPNAME() ; Display Name; PUBLIC; Extrinsic
    196         ; PREREQ: PT Defined
    197         Q:$G(PT(0))="" ""
    198         N NAME S NAME=$P(PT(0),"^",1)
    199         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    200         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    201 DOB() ; Date of Birth; PUBLIC; Extrinsic
    202         ; PREREQ: PT Defined
    203         Q:$G(PT(0))="" ""
    204         N DOB S DOB=$P(PT(0),"^",3)
    205         ; Date in FM Date Format. Convert to UTC/ISO 8601.
    206         Q $$FMDTOUTC^CCRUTIL(DOB,"D")
    207         ;
     196          ; PREREQ: PT Defined
     197          Q:$G(PT(0))="" ""
     198          N NAME S NAME=$P(PT(0),"^",1)
     199          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     200          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     201OB() ; Date of Birth; PUBLIC; Extrinsic
     202          ; PREREQ: PT Defined
     203          Q:$G(PT(0))="" ""
     204          N DOB S DOB=$P(PT(0),"^",3)
     205          ; Date in FM Date Format. Convert to UTC/ISO 8601.
     206          Q $$FMDTOUTC^CCRUTIL(DOB,"D")
     207          ;
    208208GENDER() ; Get Gender; PUBLIC; Extrinsic
    209         ; PREREQ: PT Defined
    210         Q:$G(PT(0))="" ""
    211         Q $P(PT(0),"^",2)
    212         ;
     209          ; PREREQ: PT Defined
     210          Q:$G(PT(0))="" ""
     211          Q $P(PT(0),"^",2)
     212          ;
    213213SSN() ; Get SSN for ID; PUBLIC; Extrinsic
    214         ; PREREQ: PT Defined
    215         Q:$G(PT(0))="" ""
    216         Q $P(PT(0),"^",9)
    217         ;
     214          ; PREREQ: PT Defined
     215          Q:$G(PT(0))="" ""
     216          Q $P(PT(0),"^",9)
     217          ;
    218218ADDRTYPE() ; Get Home Address; PUBLIC; Extrinsic
    219         ; Vista only stores a home address for the patient.
    220         Q:$G(PT(0))="" ""
    221         Q "Home"
    222         ;
     219          ; Vista only stores a home address for the patient.
     220          Q:$G(PT(0))="" ""
     221          Q "Home"
     222          ;
    223223ADDR1() ; Get Home Address line 1; PUBLIC; Extrinsic
    224         ; PREREQ: PT Defined
    225         Q:$G(PT(.11))="" ""
    226         Q $P(PT(.11),"^",1)
    227         ;
     224          ; PREREQ: PT Defined
     225          Q:$G(PT(.11))="" ""
     226          Q $P(PT(.11),"^",1)
     227          ;
    228228ADDR2() ; Get Home Address line 2; PUBLIC; Extrinsic
    229         ; PREREQ: PT Defined
    230         ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
    231         Q:$G(PT(.11))="" ""
    232         ; If the thrid address is empty, just return the 2nd.
    233         ; If the 2nd is empty, we don't lose, b/c it will return ""
    234         ; This is so that we won't produce a comma if there is no 3rd addr.
    235         Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2)
    236         Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3)
    237         ;
     229          ; PREREQ: PT Defined
     230          ; Vista has Lines 2,3; CCR has only line 1,2; so compromise
     231          Q:$G(PT(.11))="" ""
     232          ; If the thrid address is empty, just return the 2nd.
     233          ; If the 2nd is empty, we don't lose, b/c it will return ""
     234          ; This is so that we won't produce a comma if there is no 3rd addr.
     235          Q:$P(PT(.11),"^",3)="" $P(PT(.11),"^",2)
     236          Q $P(PT(.11),"^",2)_", "_$P(PT(.11),"^",3)
     237          ;
    238238CITY() ; Get City for Home Address; PUBLIC; Extrinsic
    239         ; PREREQ: PT Defined
    240         Q:$G(PT(.11))="" ""
    241         Q $P(PT(.11),"^",4)
    242         ;
     239          ; PREREQ: PT Defined
     240          Q:$G(PT(.11))="" ""
     241          Q $P(PT(.11),"^",4)
     242          ;
    243243STATE() ; Get State for Home Address; PUBLIC; Extrinsic
    244         ; PREREQ: PT Defined
    245         Q:$G(PT(.11))="" ""
    246         ; State is stored as a pointer
    247         N STATENUM S STATENUM=$P(PT(.11),"^",5)
    248         ;
    249         ; 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] ^
    253         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    254         Q $P(^DIC(5,STATENUM,0),"^",1)
    255         ;
     244          ; PREREQ: PT Defined
     245          Q:$G(PT(.11))="" ""
     246          ; State is stored as a pointer
     247          N STATENUM S STATENUM=$P(PT(.11),"^",5)
     248          ;
     249          ; 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] ^
     253          Q:STATENUM="" ""  ; To prevent global undefined below if no state
     254          Q $P(^DIC(5,STATENUM,0),"^",1)
     255          ;
    256256ZIP() ; Get Zip code for Home Address; PUBLIC; Extrinsic
    257         ; PREREQ: PT Defined
    258         Q:$G(PT(.11))="" ""
    259         Q $P(PT(.11),"^",6)
    260         ;
     257          ; PREREQ: PT Defined
     258          Q:$G(PT(.11))="" ""
     259          Q $P(PT(.11),"^",6)
     260          ;
    261261COUNTY() ; Get County for our Address; PUBLIC; Extrinsic
    262         ; PREREQ: PT Defined
    263         Q:$G(PT(.11))="" ""
    264         Q $P(PT(.11),"^",7)
    265         ;
     262          ; PREREQ: PT Defined
     263          Q:$G(PT(.11))="" ""
     264          Q $P(PT(.11),"^",7)
     265          ;
    266266COUNTRY() ; Get Country for our Address; PUBLIC; Extrinsic
    267         ; Unfortunately, I can't find where that is stored, so the inevitable...
    268         Q:$G(PT(.11))="" ""
    269         Q "USA"
    270         ;
     267          ; Unfortunately, I can't find where that is stored, so the inevitable...
     268          Q:$G(PT(.11))="" ""
     269          Q "USA"
     270          ;
    271271RESTEL() ; Residential Telephone; PUBLIC; Extrinsic
    272         ; PREREQ: PT Defined
    273         Q:$G(PT(.13))="" ""
    274         Q $P(PT(.13),"^",1)
    275         ;
     272          ; PREREQ: PT Defined
     273          Q:$G(PT(.13))="" ""
     274          Q $P(PT(.13),"^",1)
     275          ;
    276276WORKTEL() ; Work Telephone; PUBLIC; Extrinsic
    277         ; PREREQ: PT Defined
    278         Q:$G(PT(.13))="" ""
    279         Q $P(PT(.13),"^",2)
    280         ;
     277          ; PREREQ: PT Defined
     278          Q:$G(PT(.13))="" ""
     279          Q $P(PT(.13),"^",2)
     280          ;
    281281EMAIL() ; Email Adddress; PUBLIC; Extrinsic
    282         ; PREREQ: PT Defined
    283         Q:$G(PT(.13))="" ""
    284         Q $P(PT(.13),"^",3)
    285         ;
     282          ; PREREQ: PT Defined
     283          Q:$G(PT(.13))="" ""
     284          Q $P(PT(.13),"^",3)
     285          ;
    286286CELLTEL() ; Cell Phone; PUBLIC; Extrinsic
    287         ; PREREQ: PT Defined
    288         Q:$G(PT(.13))="" ""
    289         Q $P(PT(.13),"^",4)
    290         ;
     287          ; PREREQ: PT Defined
     288          Q:$G(PT(.13))="" ""
     289          Q $P(PT(.13),"^",4)
     290          ;
    291291NOK1FAM() ; Next of Kin 1 (NOK1) Family Name; PUBLIC; Extrinsic
    292         ; PREREQ: PT Defined
    293         Q:$G(PT(.21))="" ""
    294         N NAME S NAME=$P(PT(.21),"^",1)
    295         D NAMECOMP^XLFNAME(.NAME)
    296         Q NAME("FAMILY")
    297         ;
     292          ; PREREQ: PT Defined
     293          Q:$G(PT(.21))="" ""
     294          N NAME S NAME=$P(PT(.21),"^",1)
     295          D NAMECOMP^XLFNAME(.NAME)
     296          Q NAME("FAMILY")
     297          ;
    298298NOK1GIV() ; NOK1 Given Name; PUBLIC; Extrinsic
    299         ; PREREQ: PT Defined
    300         Q:$G(PT(.21))="" ""
    301         N NAME S NAME=$P(PT(.21),"^",1)
    302         D NAMECOMP^XLFNAME(.NAME)
    303         Q NAME("GIVEN")
    304         ;
     299          ; PREREQ: PT Defined
     300          Q:$G(PT(.21))="" ""
     301          N NAME S NAME=$P(PT(.21),"^",1)
     302          D NAMECOMP^XLFNAME(.NAME)
     303          Q NAME("GIVEN")
     304          ;
    305305NOK1MID() ; NOK1 Middle Name; PUBLIC; Extrinsic
    306         ; PREREQ: PT Defined
    307         Q:$G(PT(.21))="" ""
    308         N NAME S NAME=$P(PT(.21),"^",1)
    309         D NAMECOMP^XLFNAME(.NAME)
    310         Q NAME("MIDDLE")
    311         ;
     306          ; PREREQ: PT Defined
     307          Q:$G(PT(.21))="" ""
     308          N NAME S NAME=$P(PT(.21),"^",1)
     309          D NAMECOMP^XLFNAME(.NAME)
     310          Q NAME("MIDDLE")
     311          ;
    312312NOK1SUF() ; NOK1 Suffi Name; PUBLIC; Extrinsic
    313         ; PREREQ: PT Defined
    314         Q:$G(PT(.21))="" ""
    315         N NAME S NAME=$P(PT(.21),"^",1)
    316         D NAMECOMP^XLFNAME(.NAME)
    317         Q NAME("SUFFIX")
    318         ;
     313          ; PREREQ: PT Defined
     314          Q:$G(PT(.21))="" ""
     315          N NAME S NAME=$P(PT(.21),"^",1)
     316          D NAMECOMP^XLFNAME(.NAME)
     317          Q NAME("SUFFIX")
     318          ;
    319319NOK1DISP() ; NOK1 Display Name; PUBLIC; Extrinsic
    320         ; PREREQ: PT Defined
    321         Q:$G(PT(.21))="" ""
    322         N NAME S NAME=$P(PT(.21),"^",1)
    323         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    324         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     320          ; PREREQ: PT Defined
     321          Q:$G(PT(.21))="" ""
     322          N NAME S NAME=$P(PT(.21),"^",1)
     323          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     324          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    325325NOK1REL() ; NOK1 Relationship to the patient; PUBLIC; Extrinsic
    326         ; PREREQ: PT Defined
    327         Q:$G(PT(.21))="" ""
    328         Q $P(PT(.21),"^",2)
    329         ;
     326          ; PREREQ: PT Defined
     327          Q:$G(PT(.21))="" ""
     328          Q $P(PT(.21),"^",2)
     329          ;
    330330NOK1ADD1() ; NOK1 Address 1; PUBLIC; Extrinsic
    331         ; PREREQ: PT Defined
    332         Q:$G(PT(.21))="" ""
    333         Q $P(PT(.21),"^",3)
    334         ;
     331          ; PREREQ: PT Defined
     332          Q:$G(PT(.21))="" ""
     333          Q $P(PT(.21),"^",3)
     334          ;
    335335NOK1ADD2() ; NOK1 Address 2; PUBLIC; Extrinsic
    336         ; PREREQ: PT Defined
    337         ; As before, CCR only allows two fileds for the address, so we have to compromise
    338         Q:$G(PT(.21))="" ""
    339         ; If the thrid address is empty, just return the 2nd.
    340         ; If the 2nd is empty, we don't lose, b/c it will return ""
    341         ; This is so that we won't produce a comma if there is no 3rd addr.
    342         Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4)
    343         Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5)
    344         ;
     336          ; PREREQ: PT Defined
     337          ; As before, CCR only allows two fileds for the address, so we have to compromise
     338          Q:$G(PT(.21))="" ""
     339          ; If the thrid address is empty, just return the 2nd.
     340          ; If the 2nd is empty, we don't lose, b/c it will return ""
     341          ; This is so that we won't produce a comma if there is no 3rd addr.
     342          Q:$P(PT(.21),"^",5)="" $P(PT(.21),"^",4)
     343          Q $P(PT(.21),"^",4)_", "_$P(PT(.21),"^",5)
     344          ;
    345345NOK1CITY() ; NOK1 City; PUBLIC; Extrinsic
    346         ; PREREQ: PT Defined
    347         Q:$G(PT(.21))="" ""
    348         Q $P(PT(.21),"^",6)
    349         ;
     346          ; PREREQ: PT Defined
     347          Q:$G(PT(.21))="" ""
     348          Q $P(PT(.21),"^",6)
     349          ;
    350350NOK1STAT() ; NOK1 State; PUBLIC; Extrinsic
    351         ; PREREQ: PT Defined
    352         Q:$G(PT(.21))="" ""
    353         N STATENUM S STATENUM=$P(PT(.21),"^",7)
    354         Q:STATENUM="" ""
    355         Q $P(^DIC(5,STATENUM,0),"^",1)
    356         ;
     351          ; PREREQ: PT Defined
     352          Q:$G(PT(.21))="" ""
     353          N STATENUM S STATENUM=$P(PT(.21),"^",7)
     354          Q:STATENUM="" ""
     355          Q $P(^DIC(5,STATENUM,0),"^",1)
     356          ;
    357357NOK1ZIP() ; NOK1 Zip Code; PUBLIC; Extrinsic
    358         ; PREREQ: PT Defined
    359         Q:$G(PT(.21))="" ""
    360         Q $P(PT(.21),"^",8)
    361         ;
     358          ; PREREQ: PT Defined
     359          Q:$G(PT(.21))="" ""
     360          Q $P(PT(.21),"^",8)
     361          ;
    362362NOK1HTEL() ; NOK1 Home Telephone; PUBLIC; Extrinsic
    363         ; PREREQ: PT Defined
    364         Q:$G(PT(.21))="" ""
    365         Q $P(PT(.21),"^",9)
    366         ;
     363          ; PREREQ: PT Defined
     364          Q:$G(PT(.21))="" ""
     365          Q $P(PT(.21),"^",9)
     366          ;
    367367NOK1WTEL() ; NOK1 Work Telephone; PUBLIC; Extrinsic
    368         ; PREREQ: PT Defined
    369         Q:$G(PT(.21))="" ""
    370         Q $P(PT(.21),"^",11)
    371         ;
     368          ; PREREQ: PT Defined
     369          Q:$G(PT(.21))="" ""
     370          Q $P(PT(.21),"^",11)
     371          ;
    372372NOK1SAME() ; Is NOK1's Address the same the patient?; PUBLIC; Extrinsic
    373         ; PREREQ: PT Defined
    374         Q:$G(PT(.21))="" ""
    375         Q $P(PT(.21),"^",10)
    376         ;
     373          ; PREREQ: PT Defined
     374          Q:$G(PT(.21))="" ""
     375          Q $P(PT(.21),"^",10)
     376          ;
    377377NOK2FAM() ; NOK2 Family Name; PUBLIC; Extrinsic
    378         ; PREREQ: PT Defined
    379         Q:$G(PT(.211))="" ""
    380         N NAME S NAME=$P(PT(.211),"^",1)
    381         D NAMECOMP^XLFNAME(.NAME)
    382         Q NAME("FAMILY")
    383         ;
     378          ; PREREQ: PT Defined
     379          Q:$G(PT(.211))="" ""
     380          N NAME S NAME=$P(PT(.211),"^",1)
     381          D NAMECOMP^XLFNAME(.NAME)
     382          Q NAME("FAMILY")
     383          ;
    384384NOK2GIV() ; NOK2 Given Name; PUBLIC; Extrinsic ; PREREQ: PT Defined
    385         Q:$G(PT(.211))="" ""
    386         N NAME S NAME=$P(PT(.211),"^",1)
    387         D NAMECOMP^XLFNAME(.NAME)
    388         Q NAME("GIVEN")
    389         ;
     385          Q:$G(PT(.211))="" ""
     386          N NAME S NAME=$P(PT(.211),"^",1)
     387          D NAMECOMP^XLFNAME(.NAME)
     388          Q NAME("GIVEN")
     389          ;
    390390NOK2MID() ; NOK2 Middle Name; PUBLIC; Extrinsic
    391         ; PREREQ: PT Defined
    392         Q:$G(PT(.211))="" ""
    393         N NAME S NAME=$P(PT(.211),"^",1)
    394         D NAMECOMP^XLFNAME(.NAME)
    395         Q NAME("MIDDLE")
    396         ;
     391          ; PREREQ: PT Defined
     392          Q:$G(PT(.211))="" ""
     393          N NAME S NAME=$P(PT(.211),"^",1)
     394          D NAMECOMP^XLFNAME(.NAME)
     395          Q NAME("MIDDLE")
     396          ;
    397397NOK2SUF() ; NOK2 Suffi Name; PUBLIC; Extrinsic
    398         ; PREREQ: PT Defined
    399         Q:$G(PT(.211))="" ""
    400         N NAME S NAME=$P(PT(.211),"^",1)
    401         D NAMECOMP^XLFNAME(.NAME)
    402         Q NAME("SUFFIX")
     398          ; PREREQ: PT Defined
     399          Q:$G(PT(.211))="" ""
     400          N NAME S NAME=$P(PT(.211),"^",1)
     401          D NAMECOMP^XLFNAME(.NAME)
     402          Q NAME("SUFFIX")
    403403NOK2DISP() ; NOK2 Display Name; PUBLIC; Extrinsic
    404         ; PREREQ: PT Defined
    405         Q:$G(PT(.211))="" ""
    406         N NAME S NAME=$P(PT(.211),"^",1)
    407         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    408         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     404          ; PREREQ: PT Defined
     405          Q:$G(PT(.211))="" ""
     406          N NAME S NAME=$P(PT(.211),"^",1)
     407          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     408          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    409409NOK2REL() ; NOK2 Relationship to the patient; PUBLIC; Extrinsic
    410         ; PREREQ: PT Defined
    411         Q:$G(PT(.211))="" ""
    412         Q $P(PT(.211),"^",2)
    413         ;
     410          ; PREREQ: PT Defined
     411          Q:$G(PT(.211))="" ""
     412          Q $P(PT(.211),"^",2)
     413          ;
    414414NOK2ADD1() ; NOK2 Address 1; PUBLIC; Extrinsic
    415         ; PREREQ: PT Defined
    416         Q:$G(PT(.211))="" ""
    417         Q $P(PT(.211),"^",3)
    418         ;
     415          ; PREREQ: PT Defined
     416          Q:$G(PT(.211))="" ""
     417          Q $P(PT(.211),"^",3)
     418          ;
    419419NOK2ADD2() ; NOK2 Address 2; PUBLIC; Extrinsic
    420         ; PREREQ: PT Defined
    421         ; As before, CCR only allows two fileds for the address, so we have to compromise
    422         Q:$G(PT(.211))="" ""
    423         ; If the thrid address is empty, just return the 2nd.
    424         ; If the 2nd is empty, we don't lose, b/c it will return ""
    425         ; This is so that we won't produce a comma if there is no 3rd addr.
    426         Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4)
    427         Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5)
    428         ;
     420          ; PREREQ: PT Defined
     421          ; As before, CCR only allows two fileds for the address, so we have to compromise
     422          Q:$G(PT(.211))="" ""
     423          ; If the thrid address is empty, just return the 2nd.
     424          ; If the 2nd is empty, we don't lose, b/c it will return ""
     425          ; This is so that we won't produce a comma if there is no 3rd addr.
     426          Q:$P(PT(.211),"^",5)="" $P(PT(.211),"^",4)
     427          Q $P(PT(.211),"^",4)_", "_$P(PT(.211),"^",5)
     428          ;
    429429NOK2CITY() ; NOK2 City; PUBLIC; Extrinsic
    430         ; PREREQ: PT Defined
    431         Q:$G(PT(.211))="" ""
    432         Q $P(PT(.211),"^",6)
    433         ;
     430          ; PREREQ: PT Defined
     431          Q:$G(PT(.211))="" ""
     432          Q $P(PT(.211),"^",6)
     433          ;
    434434NOK2STAT() ; NOK2 State; PUBLIC; Extrinsic
    435         ; PREREQ: PT Defined
    436         Q:$G(PT(.211))="" ""
    437         N STATENUM S STATENUM=$P(PT(.211),"^",7)
    438         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    439         Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    440         ;
     435          ; PREREQ: PT Defined
     436          Q:$G(PT(.211))="" ""
     437          N STATENUM S STATENUM=$P(PT(.211),"^",7)
     438          Q:STATENUM="" ""  ; To prevent global undefined below if no state
     439          Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
     440          ;
    441441NOK2ZIP() ; NOK2 Zip Code; PUBLIC; Extrinsic
    442         ; PREREQ: PT Defined
    443         Q:$G(PT(.211))="" ""
    444         Q $P(PT(.211),"^",8)
    445         ;
     442          ; PREREQ: PT Defined
     443          Q:$G(PT(.211))="" ""
     444          Q $P(PT(.211),"^",8)
     445          ;
    446446NOK2HTEL() ; NOK2 Home Telephone; PUBLIC; Extrinsic
    447         ; PREREQ: PT Defined
    448         Q:$G(PT(.211))="" ""
    449         Q $P(PT(.211),"^",9)
    450         ;
     447          ; PREREQ: PT Defined
     448          Q:$G(PT(.211))="" ""
     449          Q $P(PT(.211),"^",9)
     450          ;
    451451NOK2WTEL() ; NOK2 Work Telephone; PUBLIC; Extrinsic
    452         ; PREREQ: PT Defined
    453         Q:$G(PT(.211))="" ""
    454         Q $P(PT(.211),"^",11)
    455         ;
     452          ; PREREQ: PT Defined
     453          Q:$G(PT(.211))="" ""
     454          Q $P(PT(.211),"^",11)
     455          ;
    456456NOK2SAME() ; Is NOK2's Address the same the patient?; PUBLIC; Extrinsic
    457         ; PREREQ: PT Defined
    458         Q:$G(PT(.211))="" ""
    459         Q $P(PT(.211),"^",10)
    460         ;
     457          ; PREREQ: PT Defined
     458          Q:$G(PT(.211))="" ""
     459          Q $P(PT(.211),"^",10)
     460          ;
    461461EMERFAM() ; Emergency Contact (EMER) Family Name; PUBLIC; Extrinsic
    462         ; PREREQ: PT Defined
    463         Q:$G(PT(.33))="" ""
    464         N NAME S NAME=$P(PT(.33),"^",1)
    465         D NAMECOMP^XLFNAME(.NAME)
    466         Q NAME("FAMILY")
    467         ;
     462          ; PREREQ: PT Defined
     463          Q:$G(PT(.33))="" ""
     464          N NAME S NAME=$P(PT(.33),"^",1)
     465          D NAMECOMP^XLFNAME(.NAME)
     466          Q NAME("FAMILY")
     467          ;
    468468EMERGIV() ; EMER Given Name; PUBLIC; Extrinsic
    469         ; PREREQ: PT Defined
    470         Q:$G(PT(.33))="" ""
    471         N NAME S NAME=$P(PT(.33),"^",1)
    472         D NAMECOMP^XLFNAME(.NAME)
    473         Q NAME("GIVEN")
    474         ;
     469          ; PREREQ: PT Defined
     470          Q:$G(PT(.33))="" ""
     471          N NAME S NAME=$P(PT(.33),"^",1)
     472          D NAMECOMP^XLFNAME(.NAME)
     473          Q NAME("GIVEN")
     474          ;
    475475EMERMID() ; EMER Middle Name; PUBLIC; Extrinsic
    476         ; PREREQ: PT Defined
    477         Q:$G(PT(.33))="" ""
    478         N NAME S NAME=$P(PT(.33),"^",1)
    479         D NAMECOMP^XLFNAME(.NAME)
    480         Q NAME("MIDDLE")
    481         ;
     476          ; PREREQ: PT Defined
     477          Q:$G(PT(.33))="" ""
     478          N NAME S NAME=$P(PT(.33),"^",1)
     479          D NAMECOMP^XLFNAME(.NAME)
     480          Q NAME("MIDDLE")
     481          ;
    482482EMERSUF() ; EMER Suffi Name; PUBLIC; Extrinsic
    483         ; PREREQ: PT Defined
    484         Q:$G(PT(.33))="" ""
    485         N NAME S NAME=$P(PT(.33),"^",1)
    486         D NAMECOMP^XLFNAME(.NAME)
    487         Q NAME("SUFFIX")
     483          ; PREREQ: PT Defined
     484          Q:$G(PT(.33))="" ""
     485          N NAME S NAME=$P(PT(.33),"^",1)
     486          D NAMECOMP^XLFNAME(.NAME)
     487          Q NAME("SUFFIX")
    488488EMERDISP() ; EMER Display Name; PUBLIC; Extrinsic
    489         ; PREREQ: PT Defined
    490         Q:$G(PT(.33))="" ""
    491         N NAME S NAME=$P(PT(.33),"^",1)
    492         Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
    493         ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
     489          ; PREREQ: PT Defined
     490          Q:$G(PT(.33))="" ""
     491          N NAME S NAME=$P(PT(.33),"^",1)
     492          Q $$NAMEFMT^XLFNAME(.NAME,"G","MXc")
     493          ; "G" is Given Name First; "MXc" is Mixed Case, With Suffx Preceded by Comma
    494494EMERREL() ; EMER Relationship to the patient; PUBLIC; Extrinsic
    495         ; PREREQ: PT Defined
    496         Q:$G(PT(.33))="" ""
    497         Q $P(PT(.33),"^",2)
    498         ;
     495          ; PREREQ: PT Defined
     496          Q:$G(PT(.33))="" ""
     497          Q $P(PT(.33),"^",2)
     498          ;
    499499EMERADD1() ; EMER Address 1; PUBLIC; Extrinsic
    500         ; PREREQ: PT Defined
    501         Q:$G(PT(.33))="" ""
    502         Q $P(PT(.33),"^",3)
    503         ;
     500          ; PREREQ: PT Defined
     501          Q:$G(PT(.33))="" ""
     502          Q $P(PT(.33),"^",3)
     503          ;
    504504EMERADD2() ; EMER Address 2; PUBLIC; Extrinsic
    505         ; PREREQ: PT Defined
    506         ; As before, CCR only allows two fileds for the address, so we have to compromise
    507         Q:$G(PT(.33))="" ""
    508         ; If the thrid address is empty, just return the 2nd.
    509         ; If the 2nd is empty, we don't lose, b/c it will return ""
    510         ; This is so that we won't produce a comma if there is no 3rd addr.
    511         Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4)
    512         Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5)
    513         ;
     505          ; PREREQ: PT Defined
     506          ; As before, CCR only allows two fileds for the address, so we have to compromise
     507          Q:$G(PT(.33))="" ""
     508          ; If the thrid address is empty, just return the 2nd.
     509          ; If the 2nd is empty, we don't lose, b/c it will return ""
     510          ; This is so that we won't produce a comma if there is no 3rd addr.
     511          Q:$P(PT(.33),"^",5)="" $P(PT(.33),"^",4)
     512          Q $P(PT(.33),"^",4)_", "_$P(PT(.33),"^",5)
     513          ;
    514514EMERCITY() ; EMER City; PUBLIC; Extrinsic
    515         ; PREREQ: PT Defined
    516         Q:$G(PT(.33))="" ""
    517         Q $P(PT(.33),"^",6)
    518         ;
     515          ; PREREQ: PT Defined
     516          Q:$G(PT(.33))="" ""
     517          Q $P(PT(.33),"^",6)
     518          ;
    519519EMERSTAT() ; EMER State; PUBLIC; Extrinsic
    520         ; PREREQ: PT Defined
    521         Q:$G(PT(.33))="" ""
    522         N STATENUM S STATENUM=$P(PT(.33),"^",7)
    523         Q:STATENUM="" ""  ; To prevent global undefined below if no state
    524         Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
    525         ;
     520          ; PREREQ: PT Defined
     521          Q:$G(PT(.33))="" ""
     522          N STATENUM S STATENUM=$P(PT(.33),"^",7)
     523          Q:STATENUM="" ""  ; To prevent global undefined below if no state
     524          Q $P(^DIC(5,STATENUM,0),"^",1) ; Explained above
     525          ;
    526526EMERZIP() ; EMER Zip Code; PUBLIC; Extrinsic
    527         ; PREREQ: PT Defined
    528         Q:$G(PT(.33))="" ""
    529         Q $P(PT(.33),"^",8)
    530         ;
     527          ; PREREQ: PT Defined
     528          Q:$G(PT(.33))="" ""
     529          Q $P(PT(.33),"^",8)
     530          ;
    531531EMERHTEL() ; EMER Home Telephone; PUBLIC; Extrinsic
    532         ; PREREQ: PT Defined
    533         Q:$G(PT(.33))="" ""
    534         Q $P(PT(.33),"^",9)
    535         ;
     532          ; PREREQ: PT Defined
     533          Q:$G(PT(.33))="" ""
     534          Q $P(PT(.33),"^",9)
     535          ;
    536536EMERWTEL() ; EMER Work Telephone; PUBLIC; Extrinsic
    537         ; PREREQ: PT Defined
    538         Q:$G(PT(.33))="" ""
    539         Q $P(PT(.33),"^",11)
    540         ;
     537          ; PREREQ: PT Defined
     538          Q:$G(PT(.33))="" ""
     539          Q $P(PT(.33),"^",11)
     540          ;
    541541EMERSAME() ; Is EMER's Address the same the NOK?; PUBLIC; Extrinsic
    542         ; PREREQ: PT Defined
    543         Q:$G(PT(.33))="" ""
    544         Q $P(PT(.33),"^",10)
    545         ;
     542          ; PREREQ: PT Defined
     543          Q:$G(PT(.33))="" ""
     544          Q $P(PT(.33),"^",10)
     545          ;

  • ccr/trunk/p/CCRDPTT.m

    r26 r40  
    1 CCRDPTT; Unit Tester...
    2        
    3         ; Get the functions in the routine using Rick's routine
    4         ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860"
    5         ; STATS(1,0)="CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08"
    6         ; STATS(2,0)=" ;;0.1;CCRCCD;;Jun 15, 2008;"
    7         ; STATS(84,0)="INIT(DFN) ; Copy DFN global to a local variable; PUBLIC"
    8         ; STATS(93,0)="DESTROY ; Kill local variable; PUBLIC"
    9         ; STATS(99,0)="FAMILY() ; Family Name; PUBLIC; Extrinsic"
    10         ; STATS(105,0)="GIVEN() ; Given Name; PUBLIC; Extrinsic"
    11         ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic "
    12         ; etc.
    13        
    14         ; Load Routine Entry points; We get a sweeeeeet array
    15         D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory
    16         N X,Y
    17         ; Select Patient
    18         S DIC=2,DIC(0)="AEMQ" D ^DIC
     1CCRDPTT ; Unit Tester...
     2         
     3          ; Get the functions in the routine using Rick's routine
     4          ; STATS(0)="CCRDPT^3080626.190908^396^14094^6414499860"
     5          ; STATS(1,0)="CCRDPT ;CCRCCD/SMH - Routines to Extract Patient Data for CCDCCR; 6/15/08"
     6          ; STATS(2,0)=" ;;0.1;CCRCCD;;Jun 15, 2008;"
     7          ; STATS(84,0)="INIT(DFN) ; Copy DFN global to a local variable; PUBLIC"
     8          ; STATS(93,0)="DESTROY ; Kill local variable; PUBLIC"
     9          ; STATS(99,0)="FAMILY() ; Family Name; PUBLIC; Extrinsic"
     10          ; STATS(105,0)="GIVEN() ; Given Name; PUBLIC; Extrinsic"
     11          ; STATS(111,0)="MIDDLE() ; Middle Name; PUBLIC; Extrinsic "
     12          ; etc.
     13         
     14          ; Load Routine Entry points; We get a sweeeeeet array
     15          D ANALYZE^ARJTXRD("CCRDPT",.OUT) ; Analyze a routine in the directory
     16          N X,Y
     17          ; Select Patient
     18          S DIC=2,DIC(0)="AEMQ" D ^DIC
    1919
    20         W "You have selected patient "_Y,!!
    21         D INIT^CCRDPT($P(Y,"^"))
    22         ZWR PT
    23         N I S I=165 F  S I=$O(OUT(I)) Q:I=""  D
    24         . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
    25         . W "valued at "
    26         . W @("$$"_$P(OUT(I,0),"()")_"^"_"CCRDPT"_"()")
    27         . W !
    28         Q
     20          W "You have selected patient "_Y,!!
     21          D INIT^CCRDPT($P(Y,"^"))
     22          ZWR PT
     23          N I S I=165 F  S I=$O(OUT(I)) Q:I=""  D
     24          . W "OUT("_I_",0)"_" is "_$P(OUT(I,0)," ")_" "
     25          . W "valued at "
     26          . W @("$$"_$P(OUT(I,0),"()")_"^"_"CCRDPT"_"()")
     27          . W !
     28          Q

  • ccr/trunk/p/CCRUTIL.m

    r36 r40  
    1 CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2         ;;0.1;CCRCCD;;Jun 15, 2008;
    3        
    4         W "No Entry at Top!" Q
    5        
    6 FMDTOUTC(DATE,FORMAT)   ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
    7         ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
    8         ; If not passed, or passed incorrectly, it's assumed that it is D.
    9         ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
    10         ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
    11         ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
    12         N UTC,Y,M,D,H,MM,S,OFF
    13         S Y=1700+$E(DATE,1,3)
    14         S M=$E(DATE,4,5)
    15         S D=$E(DATE,6,7)
    16         S H=$E(DATE,9,10)
    17         S MM=$E(DATE,11,12)
    18         S S=$E(DATE,13,14)
    19         S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
    20         ; If H, MM and S are empty, it means that the FM date didn't supply the time.
    21         ; In this case, set H, MM and S to "00"
    22         S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00"
    23         I S="" S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_OFF
    24         E  S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_":"_S_OFF
    25         I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
    26         E  Q $P(UTC,"T")
    27         ;
     1CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08
     2          ;;0.1;CCRCCD;;Jun 15, 2008;
     3         
     4          W "No Entry at Top!" Q
     5         
     6FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
     7          ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
     8          ; If not passed, or passed incorrectly, it's assumed that it is D.
     9          ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
     10          ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
     11          ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
     12          N UTC,Y,M,D,H,MM,S,OFF
     13          S Y=1700+$E(DATE,1,3)
     14          S M=$E(DATE,4,5)
     15          S D=$E(DATE,6,7)
     16          S H=$E(DATE,9,10)
     17          S MM=$E(DATE,11,12)
     18          S S=$E(DATE,13,14)
     19          S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
     20          ; If H, MM and S are empty, it means that the FM date didn't supply the time.
     21          ; In this case, set H, MM and S to "00"
     22          S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00"
     23          I S="" S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_OFF
     24          E  S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_":"_S_OFF
     25          I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
     26          E  Q $P(UTC,"T")
     27          ;

  • ccr/trunk/p/GPLACTORS.m

    r37 r40  
    11GPLACTORS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08
    2  ;;0.1;CCDCCR;nopatch;noreleasedate
    3  ;
    4  ;  PROCESS THE ACTORS SECTION OF THE CCR
    5  ;
     2           ;;0.1;CCDCCR;nopatch;noreleasedate
     3           ;
     4           ;  PROCESS THE ACTORS SECTION OF THE CCR
     5           ;
    66EXTRACT(IPXML,ALST,OUTXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
    7  ;
     7           ;
    88           N I,J,ATMP,FIRST,AMAP,AOID,ATYP,AIEN
    99           S FIRST=1 ; NEED TO KNOW WHICH IS THE FIRST ACTOR

  • ccr/trunk/p/GPLCCD0.m

    r3 r40  
    11GPLCCD0 ; CCDCCR/GPL - CCD TEMPLATE AND ACCESS ROUTINES; 6/7/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate
    3         W "This is a CCD TEMPLATE with processing routines",!
    4         W !
    5         Q
    6         ;
     2          ;;0.1;CCDCCR;nopatch;noreleasedate
     3          W "This is a CCD TEMPLATE with processing routines",!
     4          W !
     5          Q
     6          ;
    77ZT(ZARY,BAT,LINE) ; private routine to add a line to the ZARY array
    8         ; ZARY IS PASSED BY NAME
    9         ; BAT is a string identifying the section
    10         ; LINE is a test which will evaluate to true or false
    11         ; I '$G(@ZARY) D
    12         . S @ZARY@(0)=0 ; initially there are no elements
    13         . W "GOT HERE LOADING "_LINE,!
    14         N CNT ; count of array elements
    15         S CNT=@ZARY@(0) ; contains array count
    16         S CNT=CNT+1 ; increment count
    17         S @ZARY@(CNT)=LINE ; put the line in the array
    18         ; S @ZARY@(BAT,CNT)="" ; index the test by battery
    19         S @ZARY@(0)=CNT ; update the array counter
    20         Q
    21         ;
    22 ZLOAD(ZARY,ROUTINE)  ; load tests into ZARY which is passed by reference
    23        ; ZARY IS PASSED BY NAME
    24        ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    25        ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    26        K @ZARY S @ZARY=""
    27        S @ZARY@(0)=0 ; initialize array count
    28        N LINE,LABEL,BODY
    29        N INTEST S INTEST=0 ; switch for in the TEMPLATE section
    30        N SECTION S SECTION="[anonymous]" ; NO section LABEL
    31        ;
    32        N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    33        . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
    34        . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
    35        . I INTEST  D  ; within the section
    36        . . I LINE?." "1";><".E  D  ; sub-section name found
    37        . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
    38        . . I LINE?." "1";;".E  D  ; line found
    39        . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
    40        Q
    41        ;
     8          ; ZARY IS PASSED BY NAME
     9          ; BAT is a string identifying the section
     10          ; LINE is a test which will evaluate to true or false
     11          ; I '$G(@ZARY) D
     12          . S @ZARY@(0)=0 ; initially there are no elements
     13          . W "GOT HERE LOADING "_LINE,!
     14          N CNT ; count of array elements
     15          S CNT=@ZARY@(0) ; contains array count
     16          S CNT=CNT+1 ; increment count
     17          S @ZARY@(CNT)=LINE ; put the line in the array
     18          ; S @ZARY@(BAT,CNT)="" ; index the test by battery
     19          S @ZARY@(0)=CNT ; update the array counter
     20          Q
     21          ;
     22ZLOAD(ZARY,ROUTINE) ; load tests into ZARY which is passed by reference
     23          ; ZARY IS PASSED BY NAME
     24          ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     25          ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     26          K @ZARY S @ZARY=""
     27          S @ZARY@(0)=0 ; initialize array count
     28          N LINE,LABEL,BODY
     29          N INTEST S INTEST=0 ; switch for in the TEMPLATE section
     30          N SECTION S SECTION="[anonymous]" ; NO section LABEL
     31          ;
     32          N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     33          . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
     34          . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
     35          . I INTEST  D  ; within the section
     36          . . I LINE?." "1";><".E  D  ; sub-section name found
     37          . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
     38          . . I LINE?." "1";;".E  D  ; line found
     39          . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
     40          Q
     41          ;
    4242LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
    43         D ZLOAD(ARY,"GPLCCD0")
    44         ; ZWR @ARY
    45         Q
    46         ;
     43          D ZLOAD(ARY,"GPLCCD0")
     44          ; ZWR @ARY
     45          Q
     46          ;
    4747;<TEMPLATE>
    4848;;<?xml version="1.0"?>
    4949;;<?xml-stylesheet type="text/xsl" href="CCD.xsl"?>
    5050;;<ClinicalDocument xmlns="urn:hl7-org:v3" xmlns:voc="urn:hl7-org:v3/voc" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="urn:hl7-org:v3 CDA.xsd">
    51 ;;      <typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
    52 ;;      <templateId root="2.16.840.1.113883.10.20.1"/>
    53 ;;      <id root="db734647-fc99-424c-a864-7e3cda82e703"/>
    54 ;;      <code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
    55 ;;      <title>< value="DOCTITLE"/>@@DOCTITLE@@Good Health Clinic Continuity of Care Document</title>
    56 ;;      <effectiveTime value="@@EFFECTIVETIME@@20000407130000+0500"/>
    57 ;;      <confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
    58 ;;      <languageCode code="en-US"/>
    59 ;;      <recordTarget>
    60 ;;              <patientRole>
    61 ;;                      <id extension="996-756-495" root="2.16.840.1.113883.19.5"/>
    62 ;;                      <patient>
    63 ;;                              <name>
    64 ;;                                      <given>@@PATIENTGIVENNAME@@</given>
    65 ;;                                      <family>@@PATIENTFAMILYNAME@@</family>
    66 ;;                                      <suffix>@@PATIENTNAMESUFFIX@@</suffix>
    67 ;;                              </name>
    68 ;;                              <administrativeGenderCode code="@@PATIENTGENDER@@M" codeSystem="2.16.840.1.113883.5.1"/>
    69 ;;                              <birthTime value="@@PATIENTDATEOFBIRTH@@19320924"/>
    70 ;;                      </patient>
    71 ;;                      <providerOrganization>
    72 ;;                              <id root="2.16.840.1.113883.19.5"/>
    73 ;;                              <name>@@SITENAME@@Good Health Clinic</name>
    74 ;;                      </providerOrganization>
    75 ;;              </patientRole>
    76 ;;      </recordTarget>
    77 ;;      <author>
    78 ;;              <time value="20000407130000+0500"/>
    79 ;;              <assignedAuthor>
    80 ;;                      <id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
    81 ;;                      <assignedPerson>
    82 ;;                              <name><prefix>Dr.</prefix><given>@@AUTHORGIVENNAME@@Robert</given><family>@@AUTHORFAMILYNAME@@Dolin</family></name>
    83 ;;                      </assignedPerson>
    84 ;;                      <representedOrganization>
    85 ;;                              <id root="2.16.840.1.113883.19.5"/>
    86 ;;                              <name>@@AUTHORSITE@@Good Health Clinic</name>
    87 ;;                      </representedOrganization>
    88 ;;              </assignedAuthor>
    89 ;;      </author>
    90 ;;      <informant>
    91 ;;              <assignedEntity>
    92 ;;                      <id nullFlavor="NI"/>
    93 ;;                      <representedOrganization>
    94 ;;                              <id root="2.16.840.1.113883.19.5"/>
    95 ;;                              <name>@@INFORMANTORG@@Good Health Clinic</name>
    96 ;;                      </representedOrganization>
    97 ;;              </assignedEntity>
    98 ;;      </informant>
    99 ;;      <custodian>
    100 ;;              <assignedCustodian>
    101 ;;                      <representedCustodianOrganization>
    102 ;;                              <id root="2.16.840.1.113883.19.5"/>
    103 ;;                              <name>@@CUSTODIANORG@@Good Health Clinic</name>
    104 ;;                      </representedCustodianOrganization>
    105 ;;              </assignedCustodian>
    106 ;;      </custodian>
    107 ;;      <legalAuthenticator>
    108 ;;              <time value="20000407130000+0500"/>
    109 ;;              <signatureCode code="S"/>
    110 ;;              <assignedEntity>
    111 ;;                      <id nullFlavor="NI"/>
    112 ;;                      <representedOrganization>
    113 ;;                              <id root="2.16.840.1.113883.19.5"/>
    114 ;;                              <name>@@LEGALORG@@Good Health Clinic</name>
    115 ;;                      </representedOrganization>
    116 ;;              </assignedEntity>
    117 ;;      </legalAuthenticator>
    118 ;;      <participant typeCode="IND">
    119 ;;              <associatedEntity classCode="GUAR">
    120 ;;                      <id root="4ff51570-83a9-47b7-91f2-93ba30373141"/>
    121 ;;                      <addr>
    122 ;;                              <streetAddressLine>@@GUARSTREET@@17 Daws Rd.</streetAddressLine>
    123 ;;                              <city>@@GUARCITY@@Blue Bell</city>
    124 ;;                              <state>@@GUARSTATE@@MA</state>
    125 ;;                              <postalCode>@@GUARZIP@@02368</postalCode>
    126 ;;                      </addr>
    127 ;;                      <telecom value="tel:@@GUARTELE@@(888)555-1212"/>
    128 ;;                      <associatedPerson>
    129 ;;                              <name>
    130 ;;                                      <given>@@GUARGIVENNAME@@Kenneth</given>
    131 ;;                                      <family>@@GUARFAMILYNAME@@Ross</family>
    132 ;;                              </name>
    133 ;;                      </associatedPerson>
    134 ;;              </associatedEntity>
    135 ;;      </participant>
    136 ;;      <participant typeCode="IND">
    137 ;;              <associatedEntity classCode="NOK">
    138 ;;                      <id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
    139 ;;                      <code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="@@NOKRELATION@@Biiological mother"/>
    140 ;;                      <telecom value="tel:@@NOKTELE@@(999)555-1212"/>
    141 ;;                      <associatedPerson>
    142 ;;                              <name>
    143 ;;                                      <given>@@NOKGIVENNAME@@Henrietta</given>
    144 ;;                                      <family>@@NOKFAMILYNAME@@Levin</family>
    145 ;;                              </name>
    146 ;;                      </associatedPerson>
    147 ;;              </associatedEntity>
    148 ;;      </participant>
    149 ;;      <documentationOf>
    150 ;;              <serviceEvent classCode="PCPR">
    151 ;;                      <effectiveTime><low value="@@DOCPERIODLOW@@19320924"/><high value="@@DOCPERIODHIGH@@20000407"/></effectiveTime>
    152 ;;                      <performer typeCode="PRF">
    153 ;;                              <functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
    154 ;;                              <time><low value="@@PCPPERIODLOW@@1990"/><high value='@@PCPPERIODHIGH@@20000407'/></time>
    155 ;;                              <assignedEntity>
    156 ;;                                      <id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
    157 ;;                                      <assignedPerson>
    158 ;;                                              <name><prefix>@@PCPNAMEPREFIX@@Dr.</prefix><given>@@PCPNAMEGIVEN@@Robert</given><family>@@PCPNAMEFAMILY@@Dolin</family></name>
    159 ;;                                      </assignedPerson>
    160 ;;                                      <representedOrganization>
    161 ;;                                              <id root="2.16.840.1.113883.19.5"/>
    162 ;;                                              <name>@@PCPORG@@Good Health Clinic</name>
    163 ;;                                      </representedOrganization>
    164 ;;                              </assignedEntity>
    165 ;;                      </performer>
    166 ;;              </serviceEvent>
    167 ;;      </documentationOf>
    168 ;;      <component>
    169 ;;              <structuredBody>
     51;;<typeId root="2.16.840.1.113883.1.3" extension="POCD_HD000040"/>
     52;;<templateId root="2.16.840.1.113883.10.20.1"/>
     53;;<id root="db734647-fc99-424c-a864-7e3cda82e703"/>
     54;;<code code="34133-9" codeSystem="2.16.840.1.113883.6.1" displayName="Summarization of episode note"/>
     55;;<title>< value="DOCTITLE"/>@@DOCTITLE@@Good Health Clinic Continuity of Care Document</title>
     56;;<effectiveTime value="@@EFFECTIVETIME@@20000407130000+0500"/>
     57;;<confidentialityCode code="N" codeSystem="2.16.840.1.113883.5.25"/>
     58;;<languageCode code="en-US"/>
     59;;<recordTarget>
     60;;<patientRole>
     61;;<id extension="996-756-495" root="2.16.840.1.113883.19.5"/>
     62;;<patient>
     63;;<name>
     64;;<given>@@PATIENTGIVENNAME@@</given>
     65;;<family>@@PATIENTFAMILYNAME@@</family>
     66;;<suffix>@@PATIENTNAMESUFFIX@@</suffix>
     67;;</name>
     68;;<administrativeGenderCode code="@@PATIENTGENDER@@M" codeSystem="2.16.840.1.113883.5.1"/>
     69;;<birthTime value="@@PATIENTDATEOFBIRTH@@19320924"/>
     70;;</patient>
     71;;<providerOrganization>
     72;;<id root="2.16.840.1.113883.19.5"/>
     73;;<name>@@SITENAME@@Good Health Clinic</name>
     74;;</providerOrganization>
     75;;</patientRole>
     76;;</recordTarget>
     77;;<author>
     78;;<time value="20000407130000+0500"/>
     79;;<assignedAuthor>
     80;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
     81;;<assignedPerson>
     82;;<name><prefix>Dr.</prefix><given>@@AUTHORGIVENNAME@@Robert</given><family>@@AUTHORFAMILYNAME@@Dolin</family></name>
     83;;</assignedPerson>
     84;;<representedOrganization>
     85;;<id root="2.16.840.1.113883.19.5"/>
     86;;<name>@@AUTHORSITE@@Good Health Clinic</name>
     87;;</representedOrganization>
     88;;</assignedAuthor>
     89;;</author>
     90;;<informant>
     91;;<assignedEntity>
     92;;<id nullFlavor="NI"/>
     93;;<representedOrganization>
     94;;<id root="2.16.840.1.113883.19.5"/>
     95;;<name>@@INFORMANTORG@@Good Health Clinic</name>
     96;;</representedOrganization>
     97;;</assignedEntity>
     98;;</informant>
     99;;<custodian>
     100;;<assignedCustodian>
     101;;<representedCustodianOrganization>
     102;;<id root="2.16.840.1.113883.19.5"/>
     103;;<name>@@CUSTODIANORG@@Good Health Clinic</name>
     104;;</representedCustodianOrganization>
     105;;</assignedCustodian>
     106;;</custodian>
     107;;<legalAuthenticator>
     108;;<time value="20000407130000+0500"/>
     109;;<signatureCode code="S"/>
     110;;<assignedEntity>
     111;;<id nullFlavor="NI"/>
     112;;<representedOrganization>
     113;;<id root="2.16.840.1.113883.19.5"/>
     114;;<name>@@LEGALORG@@Good Health Clinic</name>
     115;;</representedOrganization>
     116;;</assignedEntity>
     117;;</legalAuthenticator>
     118;;<participant typeCode="IND">
     119;;<associatedEntity classCode="GUAR">
     120;;<id root="4ff51570-83a9-47b7-91f2-93ba30373141"/>
     121;;<addr>
     122;;<streetAddressLine>@@GUARSTREET@@17 Daws Rd.</streetAddressLine>
     123;;<city>@@GUARCITY@@Blue Bell</city>
     124;;<state>@@GUARSTATE@@MA</state>
     125;;<postalCode>@@GUARZIP@@02368</postalCode>
     126;;</addr>
     127;;<telecom value="tel:@@GUARTELE@@(888)555-1212"/>
     128;;<associatedPerson>
     129;;<name>
     130;;<given>@@GUARGIVENNAME@@Kenneth</given>
     131;;<family>@@GUARFAMILYNAME@@Ross</family>
     132;;</name>
     133;;</associatedPerson>
     134;;</associatedEntity>
     135;;</participant>
     136;;<participant typeCode="IND">
     137;;<associatedEntity classCode="NOK">
     138;;<id root="4ac71514-6a10-4164-9715-f8d96af48e6d"/>
     139;;<code code="65656005" codeSystem="2.16.840.1.113883.6.96" displayName="@@NOKRELATION@@Biiological mother"/>
     140;;<telecom value="tel:@@NOKTELE@@(999)555-1212"/>
     141;;<associatedPerson>
     142;;<name>
     143;;<given>@@NOKGIVENNAME@@Henrietta</given>
     144;;<family>@@NOKFAMILYNAME@@Levin</family>
     145;;</name>
     146;;</associatedPerson>
     147;;</associatedEntity>
     148;;</participant>
     149;;<documentationOf>
     150;;<serviceEvent classCode="PCPR">
     151;;<effectiveTime><low value="@@DOCPERIODLOW@@19320924"/><high value="@@DOCPERIODHIGH@@20000407"/></effectiveTime>
     152;;<performer typeCode="PRF">
     153;;<functionCode code="PCP" codeSystem="2.16.840.1.113883.5.88"/>
     154;;<time><low value="@@PCPPERIODLOW@@1990"/><high value='@@PCPPERIODHIGH@@20000407'/></time>
     155;;<assignedEntity>
     156;;<id root="20cf14fb-b65c-4c8c-a54d-b0cca834c18c"/>
     157;;<assignedPerson>
     158;;<name><prefix>@@PCPNAMEPREFIX@@Dr.</prefix><given>@@PCPNAMEGIVEN@@Robert</given><family>@@PCPNAMEFAMILY@@Dolin</family></name>
     159;;</assignedPerson>
     160;;<representedOrganization>
     161;;<id root="2.16.840.1.113883.19.5"/>
     162;;<name>@@PCPORG@@Good Health Clinic</name>
     163;;</representedOrganization>
     164;;</assignedEntity>
     165;;</performer>
     166;;</serviceEvent>
     167;;</documentationOf>
     168;;<component>
     169;;<structuredBody>
    170170;;<component>
    171171;;<section>
    172 ;;      <templateId root='2.16.840.1.113883.10.20.1.13'/>
    173 ;;      <code code="48764-5" codeSystem="2.16.840.1.113883.6.1"/>
    174 ;;      <title>Summary Purpose</title>
    175 ;;      <text>Transfer of care</text>
    176 ;;      <entry typeCode="DRIV">
    177 ;;              <act classCode="ACT" moodCode="EVN">
    178 ;;                      <templateId root='2.16.840.1.113883.10.20.1.30'/>
    179 ;;                      <code code="23745001" codeSystem="2.16.840.1.113883.6.96" displayName="Documentation procedure"/>
    180 ;;                      <statusCode code="completed"/>
    181 ;;                      <entryRelationship typeCode="RSON">
    182 ;;                              <act classCode="ACT" moodCode="EVN">
    183 ;;                                      <code code="308292007" codeSystem="2.16.840.1.113883.6.96" displayName="@@DOCPURPOSE@@Transfer of care"/>
    184 ;;                                      <statusCode code="completed"/>
    185 ;;                              </act>
    186 ;;                      </entryRelationship>
    187 ;;              </act>
    188 ;;      </entry>
     172;;<templateId root='2.16.840.1.113883.10.20.1.13'/>
     173;;<code code="48764-5" codeSystem="2.16.840.1.113883.6.1"/>
     174;;<title>Summary Purpose</title>
     175;;<text>Transfer of care</text>
     176;;<entry typeCode="DRIV">
     177;;<act classCode="ACT" moodCode="EVN">
     178;;<templateId root='2.16.840.1.113883.10.20.1.30'/>
     179;;<code code="23745001" codeSystem="2.16.840.1.113883.6.96" displayName="Documentation procedure"/>
     180;;<statusCode code="completed"/>
     181;;<entryRelationship typeCode="RSON">
     182;;<act classCode="ACT" moodCode="EVN">
     183;;<code code="308292007" codeSystem="2.16.840.1.113883.6.96" displayName="@@DOCPURPOSE@@Transfer of care"/>
     184;;<statusCode code="completed"/>
     185;;</act>
     186;;</entryRelationship>
     187;;</act>
     188;;</entry>
    189189;;</section>
    190190;;</component>
    191191;;<component>
    192192;;<section>
    193 ;;      <templateId root="2.16.840.1.113883.10.20.1.14"/>
    194 ;;      <code code="30954-2" codeSystem="2.16.840.1.113883.6.1"/>
    195 ;;      <entry typeCode="DRIV">
    196 ;;              <organizer classCode="BATTERY" moodCode="EVN">
    197 ;;                      <templateId root="2.16.840.1.113883.10.20.1.32"/>
    198 ;;                      <id root="7d5a02b0-67a4-11db-bd13-0800200c9a66"/>
    199 ;;                      <code code="@@BATTERYCODE@@43789009" codeSystem="@@BATTERYSYSTEM@@2.16.840.1.113883.6.96" displayName="@@BATTERYNAME@@CBC WO DIFFERENTIAL"/>
    200 ;;                      <statusCode code="completed"/>
    201 ;;                      <effectiveTime value="@@BATTERYTIME@@200003231430"/>
    202 ;;                      <component>
    203 ;;                              <observation classCode="OBS" moodCode="EVN">
    204 ;;                                      <templateId root="2.16.840.1.113883.10.20.1.31"/>
    205 ;;                                      <id root="107c2dc0-67a5-11db-bd13-0800200c9a66"/>
    206 ;;                                      <code code="@@COMPONENTCODE@@30313-1" codeSystem="@@COMPONENTSYSTEM@@2.16.840.1.113883.6.1" displayName="@@COMPONENTNAME@@HGB"/>
    207 ;;                                      <statusCode code="completed"/>
    208 ;;                                      <effectiveTime value="@@COMPONENTTIME@@200003231430"/>
    209 ;;                                      <value xsi:type="@@COMPONENTTYPE@@PQ" value="@@COMPONENTVALUE@13.2" unit="@@COMPONENTUNIT@@g/dl"/>
    210 ;;                                      <interpretationCode code="N" codeSystem="2.16.840.1.113883.5.83"/>
    211 ;;                                      <referenceRange>
    212 ;;                                              < value="OBSERVATIONRANGE"/>
    213 ;;                                              <observationRange>
    214 ;;                                                      <text>@@OBSRANGETEXT@@M 13-18 g/dl; F 12-16 g/dl</text>
    215 ;;                                              </observationRange>
    216 ;;                                      </referenceRange>
    217 ;;                              </observation>
    218 ;;                      </component>
    219 ;;              </organizer>
    220 ;;      </entry>
     193;;<templateId root="2.16.840.1.113883.10.20.1.14"/>
     194;;<code code="30954-2" codeSystem="2.16.840.1.113883.6.1"/>
     195;;<entry typeCode="DRIV">
     196;;<organizer classCode="BATTERY" moodCode="EVN">
     197;;<templateId root="2.16.840.1.113883.10.20.1.32"/>
     198;;<id root="7d5a02b0-67a4-11db-bd13-0800200c9a66"/>
     199;;<code code="@@BATTERYCODE@@43789009" codeSystem="@@BATTERYSYSTEM@@2.16.840.1.113883.6.96" displayName="@@BATTERYNAME@@CBC WO DIFFERENTIAL"/>
     200;;<statusCode code="completed"/>
     201;;<effectiveTime value="@@BATTERYTIME@@200003231430"/>
     202;;<component>
     203;;<observation classCode="OBS" moodCode="EVN">
     204;;<templateId root="2.16.840.1.113883.10.20.1.31"/>
     205;;<id root="107c2dc0-67a5-11db-bd13-0800200c9a66"/>
     206;;<code code="@@COMPONENTCODE@@30313-1" codeSystem="@@COMPONENTSYSTEM@@2.16.840.1.113883.6.1" displayName="@@COMPONENTNAME@@HGB"/>
     207;;<statusCode code="completed"/>
     208;;<effectiveTime value="@@COMPONENTTIME@@200003231430"/>
     209;;<value xsi:type="@@COMPONENTTYPE@@PQ" value="@@COMPONENTVALUE@13.2" unit="@@COMPONENTUNIT@@g/dl"/>
     210;;<interpretationCode code="N" codeSystem="2.16.840.1.113883.5.83"/>
     211;;<referenceRange>
     212;;<value="OBSERVATIONRANGE"/>
     213;;<observationRange>
     214;;<text>@@OBSRANGETEXT@@M 13-18 g/dl; F 12-16 g/dl</text>
     215;;</observationRange>
     216;;</referenceRange>
     217;;</observation>
     218;;</component>
     219;;</organizer>
     220;;</entry>
    221221;;</section>
    222222;;</component>

  • ccr/trunk/p/GPLCCR0.m

    r36 r40  
    1 GPLCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
    2                ;;0.1;CCDCCR;nopatch;noreleasedate
    3                W "This is a CCR TEMPLATE with processing routines",!
    4                W !
    5                Q
    6                ;
     1GPLCCR0 ; CCDCCR/GPL - CCR TEMPLATE AND ACCESS ROUTINES; 5/31/08
     2          ;;0.1;CCDCCR;nopatch;noreleasedate
     3          W "This is a CCR TEMPLATE with processing routines",!
     4          W !
     5          Q
     6          ;
    77ZT(ZARY,BAT,LINE)       ; private routine to add a line to the ZARY array
    8                ; ZARY IS PASSED BY NAME
    9                ; BAT is a string identifying the section
    10                ; LINE is a test which will evaluate to true or false
    11                ; I '$G(@ZARY) D
    12                . S @ZARY@(0)=0 ; initially there are no elements
    13                . W "GOT HERE LOADING "_LINE,!
    14                N CNT ; count of array elements
    15                S CNT=@ZARY@(0) ; contains array count
    16                S CNT=CNT+1 ; increment count
    17                S @ZARY@(CNT)=LINE ; put the line in the array
    18                ; S @ZARY@(BAT,CNT)="" ; index the test by battery
    19                S @ZARY@(0)=CNT ; update the array counter
    20                Q
    21                ;
     8          ; ZARY IS PASSED BY NAME
     9          ; BAT is a string identifying the section
     10          ; LINE is a test which will evaluate to true or false
     11          ; I '$G(@ZARY) D
     12          . S @ZARY@(0)=0 ; initially there are no elements
     13          . W "GOT HERE LOADING "_LINE,!
     14          N CNT ; count of array elements
     15          S CNT=@ZARY@(0) ; contains array count
     16          S CNT=CNT+1 ; increment count
     17          S @ZARY@(CNT)=LINE ; put the line in the array
     18          ; S @ZARY@(BAT,CNT)="" ; index the test by battery
     19          S @ZARY@(0)=CNT ; update the array counter
     20          Q
     21          ;
    2222ZLOAD(ZARY,ROUTINE)      ; load tests into ZARY which is passed by reference
    23               ; ZARY IS PASSED BY NAME
    24               ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    25               ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    26               K @ZARY S @ZARY=""
    27               S @ZARY@(0)=0 ; initialize array count
    28               N LINE,LABEL,BODY
    29               N INTEST S INTEST=0 ; switch for in the TEMPLATE section
    30               N SECTION S SECTION="[anonymous]" ; NO section LABEL
    31               ;
    32               N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    33               . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
    34               . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
    35               . I INTEST  D  ; within the section
    36               . . I LINE?." "1";><".E  D  ; sub-section name found
    37               . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
    38               . . I LINE?." "1";;".E  D  ; line found
    39               . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
    40               Q
    41               ;
     23          ; ZARY IS PASSED BY NAME
     24          ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     25          ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     26          K @ZARY S @ZARY=""
     27          S @ZARY@(0)=0 ; initialize array count
     28          N LINE,LABEL,BODY
     29          N INTEST S INTEST=0 ; switch for in the TEMPLATE section
     30          N SECTION S SECTION="[anonymous]" ; NO section LABEL
     31          ;
     32          N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     33          . I LINE?." "1";<TEMPLATE>".E S INTEST=1 ; entering section
     34          . I LINE?." "1";</TEMPLATE>".E S INTEST=0 ; leaving section
     35          . I INTEST  D  ; within the section
     36          . . I LINE?." "1";><".E  D  ; sub-section name found
     37          . . . S SECTION=$P($P(LINE,";><",2),">",1) ; pull out name
     38          . . I LINE?." "1";;".E  D  ; line found
     39          . . . D ZT(ZARY,SECTION,$P(LINE,";;",2)) ; put the line in the array
     40          Q
     41          ;
    4242LOAD(ARY)       ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
    43                D ZLOAD(ARY,"GPLCCR0")
    44                ; ZWR @ARY
    45                Q
    46                ;
     43          D ZLOAD(ARY,"GPLCCR0")
     44          ; ZWR @ARY
     45          Q
     46          ;
    4747;<TEMPLATE>
    4848;;<?xml version="1.0" encoding="UTF-8"?>

  • ccr/trunk/p/GPLPROBS.m

    r22 r40  
    11GPLPROBS ; CCDCCR/GPL - CCR/CCD PROCESSING FOR PROBLEMS ; 6/6/08
    2  ;;0.1;CCDCCR;nopatch;noreleasedate
    3  ;
    4  ;  PROCESS THE PROBLEMS SECTION OF THE CCR
    5  ;
     2           ;;0.1;CCDCCR;nopatch;noreleasedate
     3           ;
     4           ;  PROCESS THE PROBLEMS SECTION OF THE CCR
     5           ;
    66EXTRACT(IPXML,DFN,OUTXML) ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
    7  ;
    8  ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    9  ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
    10  ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
    11  ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
    12  ; INSERT^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
    13  ;
    14     N RPCRSLT,J,K,PTMP,X,VMAP,TBUF
    15     D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
    16     I '$D(RPCRSLT(0)) W "ERROR CALLING LIST^ORQQPL3 ",! Q
    17     ZWR RPCRSLT
    18     S TVMAP=$NA(^TMP($J,"PROBVALS"))
    19     S TARYTMP=$NA(^TMP($J,"PROBARYTMP"))
    20     F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
    21     . S VMAP=$NA(@TVMAP@(J))
    22     . K @VMAP
    23     . I DEBUG W "VMAP= ",VMAP,!
    24     . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
    25     . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
    26     . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
    27     . S @VMAP@("PROBLEMSTATUS")=$P(PTMP,U,2)
    28     . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
    29     . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
    30     . S @VMAP@("PROBLEMDATEOFONSET")=$P(PTMP,U,5)
    31     . S @VMAP@("PROBLEMDATEMOD")=$P(PTMP,U,6)
    32     . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
    33     . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
    34     . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
    35     . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
    36     . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
    37     . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
    38     . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
    39     . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
    40     . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
    41     . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
    42     . S @VMAP@("PROBLEMDTREC")=$P(PTMP,U,15)
    43     . S @VMAP@("PROBLEMINACT")=$P(PTMP,U,16)
    44     . S ARYTMP=$NA(@TARYTMP@(J))
    45     . ; W "ARYTMP= ",ARYTMP,!
    46     . K @ARYTMP
    47     . D MAP^GPLXPATH(IPXML,VMAP,ARYTMP) ;
    48     . I J=1 D  ; FIRST ONE IS JUST A COPY
    49     . . ; W "FIRST ONE",!
    50     . . D CP^GPLXPATH(ARYTMP,OUTXML)
    51     . . ; W "OUTXML ",OUTXML,!
    52     . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    53     . . D INSINNER^GPLXPATH(OUTXML,ARYTMP)
    54     ; ZWR ^TMP($J,"PROBVALS",*)
    55     ; ZWR ^TMP($J,"PROBARYTMP",*) ; SHOW THE RESULTS
    56     ; ZWR @OUTXML
    57     ; $$HTML^DILF(
    58     N PROBSTMP,I
    59     D MISSING^GPLXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
    60     I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS - STRINGS MARKED AS @@X@@
    61     . W "PROBLEMS Missing list: ",!
    62     . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
    63     Q
     7          ;
     8          ; INXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     9          ; INXML WILL CONTAIN ONLY THE PROBLEM SECTION OF THE OVERALL TEMPLATE
     10          ; ONLY THE XML FOR ONE PROBLEM WILL BE PASSED. THIS ROUTINE WILL MAKE
     11          ; COPIES AS NECESSARY TO REPRESENT MULTIPLE PROBLEMS
     12          ; INSERT^GPLXPATH IS USED TO APPEND THE PROBLEMS TO THE OUTPUT
     13          ;
     14          N RPCRSLT,J,K,PTMP,X,VMAP,TBUF
     15          D LIST^ORQQPL3(.RPCRSLT,DFN,"") ; CALL THE PROBLEM LIST RPC
     16          I '$D(RPCRSLT(0)) W "ERROR CALLING LIST^ORQQPL3 ",! Q
     17          ZWR RPCRSLT
     18          S TVMAP=$NA(^TMP($J,"PROBVALS"))
     19          S TARYTMP=$NA(^TMP($J,"PROBARYTMP"))
     20          F J=1:1:RPCRSLT(0)  D  ; FOR EACH PROBLEM IN THE LIST
     21          . S VMAP=$NA(@TVMAP@(J))
     22          . K @VMAP
     23          . I DEBUG W "VMAP= ",VMAP,!
     24          . S PTMP=RPCRSLT(J) ; PULL OUT PROBLEM FROM RPC RETURN ARRAY
     25          . S @VMAP@("PROBLEMOBJECTID")="PROBLEM"_J ; UNIQUE OBJID FOR PROBLEM
     26          . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1)
     27          . S @VMAP@("PROBLEMSTATUS")=$P(PTMP,U,2)
     28          . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3)
     29          . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4)
     30          . S @VMAP@("PROBLEMDATEOFONSET")=$P(PTMP,U,5)
     31          . S @VMAP@("PROBLEMDATEMOD")=$P(PTMP,U,6)
     32          . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7)
     33          . S @VMAP@("PROBLEMSE")=$P(PTMP,U,8)
     34          . S @VMAP@("PROBLEMCONDITION")=$P(PTMP,U,9)
     35          . S @VMAP@("PROBLEMLOC")=$P(PTMP,U,10)
     36          . S @VMAP@("PROBLEMLOCTYPE")=$P(PTMP,U,11)
     37          . S @VMAP@("PROBLEMPROVIDER")=$P(PTMP,U,12)
     38          . S X=@VMAP@("PROBLEMPROVIDER") ; FORMAT Y;NAME Y IS IEN OF PROVIDER
     39          . S @VMAP@("PROBLEMSOURCEACTORID")="ACTORPROVIDER_"_$P(X,";",1)
     40          . S @VMAP@("PROBLEMSERVICE")=$P(PTMP,U,13)
     41          . S @VMAP@("PROBLEMHASCMT")=$P(PTMP,U,14)
     42          . S @VMAP@("PROBLEMDTREC")=$P(PTMP,U,15)
     43          . S @VMAP@("PROBLEMINACT")=$P(PTMP,U,16)
     44          . S ARYTMP=$NA(@TARYTMP@(J))
     45          . ; W "ARYTMP= ",ARYTMP,!
     46          . K @ARYTMP
     47          . D MAP^GPLXPATH(IPXML,VMAP,ARYTMP) ;
     48          . I J=1 D  ; FIRST ONE IS JUST A COPY
     49          . . ; W "FIRST ONE",!
     50          . . D CP^GPLXPATH(ARYTMP,OUTXML)
     51          . . ; W "OUTXML ",OUTXML,!
     52          . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     53          . . D INSINNER^GPLXPATH(OUTXML,ARYTMP)
     54          ; ZWR ^TMP($J,"PROBVALS",*)
     55          ; ZWR ^TMP($J,"PROBARYTMP",*) ; SHOW THE RESULTS
     56          ; ZWR @OUTXML
     57          ; $$HTML^DILF(
     58          N PROBSTMP,I
     59          D MISSING^GPLXPATH(ARYTMP,"PROBSTMP") ; SEARCH XML FOR MISSING VARS
     60          I PROBSTMP(0)>0  D  ; IF THERE ARE MISSING VARS - STRINGS MARKED AS @@X@@
     61          . W "PROBLEMS Missing list: ",!
     62          . F I=1:1:PROBSTMP(0) W PROBSTMP(I),!
     63          Q
     64          ;

  • ccr/trunk/p/GPLUNIT.m

    r28 r40  
    11GPLUNIT ; CCDCCR/GPL - Unit Testing Library; 5/07/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate
    3         W "This is a unit testing library",!
    4         W !
    5         Q
    6         ;
     2          ;;0.1;CCDCCR;nopatch;noreleasedate
     3          W "This is a unit testing library",!
     4          W !
     5          Q
     6          ;
    77ZT(ZARY,BAT,TST) ; private routine to add a test case to the ZARY array
    8         ; ZARY IS PASSED BY REFERENCE
    9         ; BAT is a string identifying the test battery
    10         ; TST is a test which will evaluate to true or false
    11         ; I '$G(ZARY) D
    12         ; . S ZARY(0)=0 ; initially there are no elements
    13         ; W "GOT HERE LOADING "_TST,!
    14         N CNT ; count of array elements
    15         S CNT=ZARY(0) ; contains array count
    16         S CNT=CNT+1 ; increment count
    17         S ZARY(CNT)=TST ; put the test in the array
    18         I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
    19         . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
    20         . S II=$P(ZARY(BAT),"^",2)
    21         . S $P(ZARY(BAT),"^",2)=II+1
    22         I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
    23         . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
    24         . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
    25         . ; S TN=$NA(ZARY("TESTS"))
    26         . ; D PUSH^GPLXPATH(TN,BAT)
    27         S ZARY(0)=CNT ; update the array counter
    28         Q
    29         ;
     8          ; ZARY IS PASSED BY REFERENCE
     9          ; BAT is a string identifying the test battery
     10          ; TST is a test which will evaluate to true or false
     11          ; I '$G(ZARY) D
     12          ; . S ZARY(0)=0 ; initially there are no elements
     13          ; W "GOT HERE LOADING "_TST,!
     14          N CNT ; count of array elements
     15          S CNT=ZARY(0) ; contains array count
     16          S CNT=CNT+1 ; increment count
     17          S ZARY(CNT)=TST ; put the test in the array
     18          I $D(ZARY(BAT))  D  ; NOT THE FIRST TEST IN BATTERY
     19          . N II,TN ; TEMP FOR ENDING TEST IN BATTERY
     20          . S II=$P(ZARY(BAT),"^",2)
     21          . S $P(ZARY(BAT),"^",2)=II+1
     22          I '$D(ZARY(BAT))  D  ; FIRST TEST IN THIS BATTERY
     23          . S ZARY(BAT)=CNT_"^"_CNT ; FIRST AND LAST TESTS IN BATTERY
     24          . S ZARY("TESTS",BAT)="" ; PUT THE BATTERY IN THE TESTS INDEX
     25          . ; S TN=$NA(ZARY("TESTS"))
     26          . ; D PUSH^GPLXPATH(TN,BAT)
     27          S ZARY(0)=CNT ; update the array counter
     28          Q
     29          ;
    3030ZLOAD(ZARY,ROUTINE)  ; load tests into ZARY which is passed by reference
    31        ; ZARY IS PASSED BY NAME
    32        ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
    33        ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
    34        K @ZARY
    35        S @ZARY@(0)=0 ; initialize array count
    36        N LINE,LABEL,BODY
    37        N INTEST S INTEST=0 ; switch for in the test case section
    38        N SECTION S SECTION="[anonymous]" ; test case section
    39        ;
    40        N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
    41        . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
    42        . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
    43        . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
    44        . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
    45        . I INTEST  D  ; within the testing section
    46        . . I LINE?." "1";;><".E  D  ; section name found
    47        . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
    48        . . I LINE?." "1";;>>".E  D  ; test case found
    49        . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
    50        S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
    51        Q
    52        ;
     31          ; ZARY IS PASSED BY NAME
     32          ; ZARY = name of the root, closed array format (e.g., "^TMP($J)")
     33          ; ROUTINE = NAME OF THE ROUTINE - PASSED BY VALUE
     34          K @ZARY
     35          S @ZARY@(0)=0 ; initialize array count
     36          N LINE,LABEL,BODY
     37          N INTEST S INTEST=0 ; switch for in the test case section
     38          N SECTION S SECTION="[anonymous]" ; test case section
     39          ;
     40          N NUM F NUM=1:1 S LINE=$T(+NUM^@ROUTINE) Q:LINE=""  D
     41          . I LINE?." "1";;><TEST>".E S INTEST=1 ; entering test section
     42          . I LINE?." "1";;><TEMPLATE>".E S INTEST=1 ; entering TEMPLATE section
     43          . I LINE?." "1";;></TEST>".E S INTEST=0 ; leaving test section
     44          . I LINE?." "1";;></TEMPLATE>".E S INTEST=0 ; leaving TEMPLATE section
     45          . I INTEST  D  ; within the testing section
     46          . . I LINE?." "1";;><".E  D  ; section name found
     47          . . . S SECTION=$P($P(LINE,";;><",2),">",1) ; pull out name
     48          . . I LINE?." "1";;>>".E  D  ; test case found
     49          . . . D ZT(.@ZARY,SECTION,$P(LINE,";;>>",2)) ; put the test in the array
     50          S @ZARY@("ALL")="1"_"^"_@ZARY@(0) ; MAKE A BATTERY FOR ALL
     51          Q
     52          ;
    5353ZTEST(ZARY,WHICH)   ; try out the tests using a passed array ZTEST
    54         N I,ZX,ZR,ZP
    55         S DEBUG=0
    56         ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
    57         ; . W "DOING ALL",!
    58         ; . N J,NT
    59         ; . S NT=$NA(ZARY("TESTS"))
    60         ; . W NT,@NT@(0),!
    61         ; . F J=1:1:@NT@(0) D  ;
    62         ; . . W @NT@(J),!
    63         ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J))
    64         I '$D(ZARY(WHICH))  D  ; TEST SECTION DOESN'T EXIST
    65         . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
    66         . Q ; EXIT
    67         N FIRST,LAST
    68         S FIRST=$P(ZARY(WHICH),"^",1)
    69         S LAST=$P(ZARY(WHICH),"^",2)
    70         F I=FIRST:1:LAST  D
    71         . I ZARY(I)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
    72         . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
    73         . . ;  W ZP,!
    74         . . S ZX=ZP
    75         . . W "RUNNING: "_ZP
    76         . . X ZX
    77         . . W "..SUCCESS: ",WHICH,!
    78         . I ZARY(I)?1"?"1.E  D  ; THIS IS A TEST
    79         . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
    80         . . S ZX="S ZR="_ZP
    81         . . W "TRYING: "_ZP
    82         . . X ZX
    83         . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
    84         . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
    85         . . . S TPASSED=0 S TFAILED=0
    86         . . I ZR S TPASSED=TPASSED+1
    87         . . I 'ZR S TFAILED=TFAILED+1
    88         Q
    89         ;
     54          N I,ZX,ZR,ZP
     55          S DEBUG=0
     56          ; I WHICH="ALL" D  Q ; RUN ALL THE TESTS
     57          ; . W "DOING ALL",!
     58          ; . N J,NT
     59          ; . S NT=$NA(ZARY("TESTS"))
     60          ; . W NT,@NT@(0),!
     61          ; . F J=1:1:@NT@(0) D  ;
     62          ; . . W @NT@(J),!
     63          ; . . D ZTEST^GPLUNIT(@ZARY,@NT@(J))
     64          I '$D(ZARY(WHICH))  D  ; TEST SECTION DOESN'T EXIST
     65          . W "ERROR -- TEST SECTION DOESN'T EXIST -> ",WHICH,!
     66          . Q ; EXIT
     67          N FIRST,LAST
     68          S FIRST=$P(ZARY(WHICH),"^",1)
     69          S LAST=$P(ZARY(WHICH),"^",2)
     70          F I=FIRST:1:LAST  D
     71          . I ZARY(I)?1">"1.E  D  ; NOT A TEST, JUST RUN THE STATEMENT
     72          . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
     73          . . ;  W ZP,!
     74          . . S ZX=ZP
     75          . . W "RUNNING: "_ZP
     76          . . X ZX
     77          . . W "..SUCCESS: ",WHICH,!
     78          . I ZARY(I)?1"?"1.E  D  ; THIS IS A TEST
     79          . . S ZP=$E(ZARY(I),2,$L(ZARY(I)))
     80          . . S ZX="S ZR="_ZP
     81          . . W "TRYING: "_ZP
     82          . . X ZX
     83          . . W $S(ZR=1:"..PASSED ",1:"..FAILED "),!
     84          . . I '$D(TPASSED) D  ; NOT INITIALIZED YET
     85          . . . S TPASSED=0 S TFAILED=0
     86          . . I ZR S TPASSED=TPASSED+1
     87          . . I 'ZR S TFAILED=TFAILED+1
     88          Q
     89          ;
    9090TEST   ; RUN ALL THE TEST CASES
    91       N ZTMP
    92       D ZLOAD(.ZTMP)
    93       D ZTEST(.ZTMP,"ALL")
    94       W "PASSED: ",TPASSED,!
    95       W "FAILED: ",TFAILED,!
    96       W !
    97       W "THE TESTS!",!
    98       ZWR ZTMP
    99       Q
    100       ;
     91          N ZTMP
     92          D ZLOAD(.ZTMP)
     93          D ZTEST(.ZTMP,"ALL")
     94          W "PASSED: ",TPASSED,!
     95          W "FAILED: ",TFAILED,!
     96          W !
     97          W "THE TESTS!",!
     98          ZWR ZTMP
     99          Q
     100          ;
    101101GTSTS(GTZARY,RTN) ; return an array of test names
    102         N I,J S I="" S I=$O(GTZARY("TESTS",I))
    103         F J=0:0  Q:I=""  D
    104         . D PUSH^GPLXPATH(RTN,I)
    105         . S I=$O(GTZARY("TESTS",I))
    106         Q
    107         ;
     102          N I,J S I="" S I=$O(GTZARY("TESTS",I))
     103          F J=0:0  Q:I=""  D
     104          . D PUSH^GPLXPATH(RTN,I)
     105          . S I=$O(GTZARY("TESTS",I))
     106          Q
     107          ;
    108108TESTALL(RNM) ; RUN ALL THE TESTS
    109         N I,J,TZTMP,TSTS,TOTP,TOTF
    110         S TOTP=0 S TOTF=0
    111         D ZLOAD^GPLUNIT("TZTMP",RNM)
    112         D GTSTS(.TZTMP,"TSTS")
    113         F I=1:1:TSTS(0) D  ;
    114         . S TPASSED=0 S TFAILED=0
    115         . D ZTEST^GPLUNIT(.TZTMP,TSTS(I))
    116         . S TOTP=TOTP+TPASSED
    117         . S TOTF=TOTF+TFAILED
    118         . S $P(TSTS(I),"^",2)=TPASSED
    119         . S $P(TSTS(I),"^",3)=TFAILED
    120         F I=1:1:TSTS(0) D  ;
    121         . W "TEST=> ",$P(TSTS(I),"^",1)
    122         . W " PASSED=>",$P(TSTS(I),"^",2)
    123         . W " FAILED=>",$P(TSTS(I),"^",3),!
    124         W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
    125         Q
    126         ;
     109          N I,J,TZTMP,TSTS,TOTP,TOTF
     110          S TOTP=0 S TOTF=0
     111          D ZLOAD^GPLUNIT("TZTMP",RNM)
     112          D GTSTS(.TZTMP,"TSTS")
     113          F I=1:1:TSTS(0) D  ;
     114          . S TPASSED=0 S TFAILED=0
     115          . D ZTEST^GPLUNIT(.TZTMP,TSTS(I))
     116          . S TOTP=TOTP+TPASSED
     117          . S TOTF=TOTF+TFAILED
     118          . S $P(TSTS(I),"^",2)=TPASSED
     119          . S $P(TSTS(I),"^",3)=TFAILED
     120          F I=1:1:TSTS(0) D  ;
     121          . W "TEST=> ",$P(TSTS(I),"^",1)
     122          . W " PASSED=>",$P(TSTS(I),"^",2)
     123          . W " FAILED=>",$P(TSTS(I),"^",3),!
     124          W "TOTAL=> PASSED:",TOTP," FAILED:",TOTF,!
     125          Q
     126          ;
    127127TLIST(ZARY) ; LIST ALL THE TESTS
    128      ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
    129      ; ZARY IS PASSED BY REFERENCE
    130      N I,J,K S I="" S I=$O(ZARY("TESTS",I))
    131      S K=1
    132      F J=0:0  Q:I=""  D
    133      . ; W "I IS NOW=",I,!
    134      . W I," "
    135      . S I=$O(ZARY("TESTS",I))
    136      . S K=K+1 I K=6  D
    137      . . W !
    138      . . S K=1
    139      Q
    140      ;
     128          ; THEY ARE MARKED AS ;;><TESTNAME> IN THE TEST CASES
     129          ; ZARY IS PASSED BY REFERENCE
     130          N I,J,K S I="" S I=$O(ZARY("TESTS",I))
     131          S K=1
     132          F J=0:0  Q:I=""  D
     133          . ; W "I IS NOW=",I,!
     134          . W I," "
     135          . S I=$O(ZARY("TESTS",I))
     136          . S K=K+1 I K=6  D
     137          . . W !
     138          . . S K=1
     139          Q
     140          ;

  • ccr/trunk/p/GPLVITALS.m

    r36 r40  
    1 GPLVITALS       ; CCDCCR/CJE - CCR/CCD PROCESSING FOR VITALS ; 07/03/08
    2                 ;;0.1;CCDCCR;;JUL 3,2008;
    3 EXTRACT(VITXML,DFN,VITOUTXML)   ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
    4         ;
    5         ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
    6         ; IVITXML WILL CONTAIN ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
    7         ;
    8         N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF
    9         D VITALS^ORQQVI(.VITRSLT,DFN,"","")
    10         I '$D(VITRSLT(1)) W "ERROR RUNNINIG VITALS RPC",! Q
    11         ; ZWR RPCRSLT
    12         S VITTVMAP=$NA(^TMP($J,"VITALS"))
    13         S VITTARYTMP=$NA(^TMP($J,"VITALARYTMP"))
    14         F J=1:1:VITRSLT(1)  D  ; FOR EACH VITAL IN THE LIST
    15         . I $D(VITRSLT(J)) D 
    16         . . S VITVMAP=$NA(@VITTVMAP@(J))
    17         . . K @VITVMAP
    18         . . I DEBUG W "VMAP= ",VMAP,!
    19         . . S VITPTMP=VITRSLT(J) ; PULL OUT VITAL FROM RPC RETURN ARRAY
    20         . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID FOR VITAL
    21         . . I $P(VITPTMP,U,2)="HT" D
    22         . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    23         . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
    24         . . . W "CONVERTED DATE TIME: ",@VITVMAP@("VITALSIGNSEXACTDATETIME"),!
    25         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    26         . . . ;S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
    27         . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    28         . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    29         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
    30         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
    31         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
    32         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
    33         . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
    34         . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    35         . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
    36         . . . ;S @VITVMAP@("HEIGHTWEIGHTSOURCE")=$P(VITPTMP,U,7)
    37         . . E  I $P(VITPTMP,U,2)="WT" D
    38         . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    39         . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
    40         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    41         . . . ;S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
    42         . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    43         . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    44         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
    45         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
    46         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
    47         . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
    48         . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
    49         . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    50         . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
    51         . . E  D
    52         . . . ;W "IN VITAL:  OTHER",!
    53         . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
    54         . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
    55         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
    56         . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
    57         . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
    58         . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
    59         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
    60         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
    61         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
    62         . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
    63         . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
    64         . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
    65         . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
    66         . . . ;S @VITVMAP@("HEIGHTWEIGHTSOURCE")=$P(VITPTMP,U,7)
    67         . . S VITARYTMP=$NA(@VITTARYTMP@(J))
    68         . . K @VITARYTMP
    69         . . D MAP^GPLXPATH(VITXML,VITVMAP,VITARYTMP)
    70         . . I J=1 D  ; FIRST ONE IS JUST A COPY
    71         . . . ; W "FIRST ONE",!
    72         . . . D CP^GPLXPATH(VITARYTMP,VITOUTXML)
    73         . . . ; W "OUTXML ",OUTXML,!
    74         . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
    75         . . . D INSINNER^GPLXPATH(VITOUTXML,VITARYTMP)
    76         ; ZWR ^TMP($J,"VITALS",*)
    77         ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
    78         ; ZWR @OUTXML
    79         N VITTMP,I
    80         D MISSING^GPLXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
    81         I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
    82         . W "VITALS MISSING ",!
    83         . F I=1:1:VITTMP(0) W VITTMP(I),!
    84         Q
    85         ;
     1GPLVITALS ; CCDCCR/CJE - CCR/CCD PROCESSING FOR VITALS ; 07/03/08
     2          ;;0.1;CCDCCR;;JUL 3,2008;
     3EXTRACT(VITXML,DFN,VITOUTXML)          ; EXTRACT PROBLEMS INTO PROVIDED XML TEMPLATE
     4          ;
     5          ; VITXML AND OUTXML ARE PASSED BY NAME SO GLOBALS CAN BE USED
     6          ; IVITXML WILL CONTAIN ONLY THE VITALS SECTION OF THE OVERALL TEMPLATE
     7          ;
     8          N VITRSLT,J,K,VITPTMP,X,VITVMAP,TBUF
     9          D VITALS^ORQQVI(.VITRSLT,DFN,"","")
     10          I '$D(VITRSLT(1)) W "ERROR RUNNINIG VITALS RPC",! Q
     11          ; ZWR RPCRSLT
     12          S VITTVMAP=$NA(^TMP($J,"VITALS"))
     13          S VITTARYTMP=$NA(^TMP($J,"VITALARYTMP"))
     14          F J=1:1:VITRSLT(1)  D  ; FOR EACH VITAL IN THE LIST
     15          . I $D(VITRSLT(J)) D 
     16          . . S VITVMAP=$NA(@VITTVMAP@(J))
     17          . . K @VITVMAP
     18          . . I DEBUG W "VMAP= ",VMAP,!
     19          . . S VITPTMP=VITRSLT(J) ; PULL OUT VITAL FROM RPC RETURN ARRAY
     20          . . S @VITVMAP@("VITALSIGNSDATAOBJECTID")="VITAL"_J ; UNIQUE OBJID FOR VITAL
     21          . . I $P(VITPTMP,U,2)="HT" D
     22          . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     23          . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
     24          . . . W "CONVERTED DATE TIME: ",@VITVMAP@("VITALSIGNSEXACTDATETIME"),!
     25          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     26          . . . ;S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
     27          . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     28          . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     29          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="HEIGHT"
     30          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
     31          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
     32          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
     33          . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
     34          . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     35          . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="in"
     36          . . . ;S @VITVMAP@("HEIGHTWEIGHTSOURCE")=$P(VITPTMP,U,7)
     37          . . E  I $P(VITPTMP,U,2)="WT" D
     38          . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     39          . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
     40          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     41          . . . ;S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
     42          . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     43          . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     44          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="WEIGHT"
     45          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
     46          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
     47          . . . ;S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
     48          . . . ;S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
     49          . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     50          . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="lbs"
     51          . . E  D
     52          . . . ;W "IN VITAL:  OTHER",!
     53          . . . S @VITVMAP@("VITALSIGNSDATETIMETYPETEXT")="OBSERVED"
     54          . . . S @VITVMAP@("VITALSIGNSEXACTDATETIME")=$$FMDTOUTC^CCRUTIL($P(VITPTMP,U,4),"DT")
     55          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER VITAL"
     56          . . . S @VITVMAP@("VITALSIGNSSOURCEACTORID")=""
     57          . . . S @VITVMAP@("VITALSIGNSTESTOBJECTID")="VITALTEST"_J
     58          . . . S @VITVMAP@("VITALSIGNSTESTTYPETEXT")="OBSERVED"
     59          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONTEXT")="OTHER"
     60          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVALUE")=""
     61          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODINGSYSTEM")=""
     62          . . . S @VITVMAP@("VITALSIGNSDESCRIPTIONCODEVERSION")=""
     63          . . . S @VITVMAP@("VITALSIGNSTESTSOURCEACTORID")=""
     64          . . . S @VITVMAP@("VITALSIGNSTESTRESULTVALUE")=$P(VITPTMP,U,3)
     65          . . . S @VITVMAP@("VITALSIGNSTESTRESULTUNIT")="UNKNOWN"
     66          . . . ;S @VITVMAP@("HEIGHTWEIGHTSOURCE")=$P(VITPTMP,U,7)
     67          . . S VITARYTMP=$NA(@VITTARYTMP@(J))
     68          . . K @VITARYTMP
     69          . . D MAP^GPLXPATH(VITXML,VITVMAP,VITARYTMP)
     70          . . I J=1 D  ; FIRST ONE IS JUST A COPY
     71          . . . ; W "FIRST ONE",!
     72          . . . D CP^GPLXPATH(VITARYTMP,VITOUTXML)
     73          . . . ; W "OUTXML ",OUTXML,!
     74          . . I J>1 D  ; AFTER THE FIRST, INSERT INNER XML
     75          . . . D INSINNER^GPLXPATH(VITOUTXML,VITARYTMP)
     76          ; ZWR ^TMP($J,"VITALS",*)
     77          ; ZWR ^TMP($J,"VITALARYTMP",*) ; SHOW THE RESULTS
     78          ; ZWR @OUTXML
     79          N VITTMP,I
     80          D MISSING^GPLXPATH(VITOUTXML,"VITTMP") ; SEARCH XML FOR MISSING VARS
     81          I VITTMP(0)>0 D  ; IF THERE ARE MISSING VARS - MARKED AS @@X@@
     82          . W "VITALS MISSING ",!
     83          . F I=1:1:VITTMP(0) W VITTMP(I),!
     84          Q
     85          ;
Note: See TracChangeset for help on using the changeset viewer.