source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGUTL4.m@ 1128

Last change on this file since 1128 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1DGUTL4 ;BPFO/JRP - RACE & ETHNIC UTILITIES;9/5/2002
2 ;;5.3;Registration;**415**;Aug 13, 1993
3 ;
4PTR2TEXT(VALUE,TYPE) ;Convert pointer to text (.01 field)
5 ;Input: VALUE - Pointer to RACE file (#10), ETHNICITY file (#10.2),
6 ; or RACE AND ETHNICITY COLLECTION METHOD file (#10.3)
7 ; TYPE - Flag indicating which file VALUE is for
8 ; 1 = Race (default)
9 ; 2 = Ethnicity
10 ; 3 = Collection Method
11 ;Output: Text (.01 field)
12 ;Notes : NULL ("") returned on bad input or if there is no code
13 ;
14 ;Check input
15 S VALUE=+$G(VALUE)
16 I 'VALUE Q ""
17 S TYPE=$G(TYPE)
18 S:(TYPE'?1N) TYPE=1
19 S:((TYPE<1)!(TYPE>3)) TYPE=1
20 ;Declare variables
21 N FILE,NODE
22 ;Grab zero node
23 S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10)))
24 S NODE=$G(@FILE@(VALUE,0))
25 ;Return text
26 Q $P(NODE,"^",1)
27 ;
28INACTIVE(VALUE,TYPE) ;Entry marked as inactive ?
29 ;Input: VALUE - Pointer to RACE file (#10) or ETHNICITY file (#10.2)
30 ; TYPE - Flag indicating which file VALUE is for
31 ; 1 = Race (default)
32 ; 2 = Ethnicity
33 ;Output: 0 - Entry not inactive
34 ; 1^Date - Entry inactive (Date in FileMan format)
35 ;Notes : 0 (zero) returned on bad input
36 ; : Collection methods can not currently be inactivated
37 ;
38 ;Check input
39 S VALUE=+$G(VALUE)
40 I 'VALUE Q ""
41 S TYPE=$G(TYPE)
42 S:(TYPE'?1N) TYPE=1
43 S:((TYPE<1)!(TYPE>2)) TYPE=1
44 ;Declare variables
45 N FILE,NODE,DATE
46 ;Grab inactivation node
47 S FILE=$S(TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10)))
48 S NODE=$G(@FILE@(VALUE,.02))
49 ;Grab inactivation date
50 S DATE=$P(NODE,"^",2)
51 ;Not inactive
52 I (('NODE)&('DATE)) Q 0
53 ;Inactive - include inactivation date
54 Q "1^"_DATE
55 ;
56PTR2CODE(VALUE,TYPE,CODE) ;Convert pointer to specified code
57 ;Input: VALUE - Pointer to RACE file (#10), ETHNICITY file (#10.2),
58 ; or RACE AND ETHNICITY COLLECTION METHOD file (#10.3)
59 ; TYPE - Flag indicating which file VALUE is for
60 ; 1 = Race (default)
61 ; 2 = Ethnicity
62 ; 3 = Collection Method
63 ; CODE - Flag indicating which code to return
64 ; 1 = Abbreviation (default)
65 ; 2 = HL7
66 ; 3 = CDC (not applicable for Collection Method)
67 ; 4 = PTF
68 ;Output: Requested code
69 ;Notes : NULL ("") returned on bad input or if there is no code
70 ;
71 ;Check input
72 S VALUE=+$G(VALUE)
73 I 'VALUE Q ""
74 S TYPE=$G(TYPE)
75 S:(TYPE'?1N) TYPE=1
76 S:((TYPE<1)!(TYPE>3)) TYPE=1
77 S CODE=$G(CODE)
78 S:(CODE'?1N) CODE=1
79 S:((CODE<1)!(CODE>4)) CODE=1
80 ;No CDC code for Collection Method
81 I ((TYPE=3)&(CODE=3)) Q ""
82 ;Declare variables
83 N FILE,NODEREF,NODE,PIECE
84 ;Grab node storing code
85 S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10)))
86 S NODEREF=0
87 S NODE=$G(@FILE@(VALUE,NODEREF))
88 ;Determine which piece requested code is in
89 S PIECE=CODE+1
90 ;Return requested code
91 Q $P(NODE,"^",PIECE)
92 ;
93CODE2PTR(VALUE,TYPE,CODE) ;Convert specified code to pointer
94 ;Input: VALUE - Code to convert
95 ; TYPE - Flag indicating which file VALUE is from
96 ; 1 = Race (file #10) (default)
97 ; 2 = Ethnicity (file #10.2)
98 ; 3 = Collection Method (file #10.3)
99 ; CODE - Flag indicating which code VALUE is for
100 ; 1 = Abbreviation (default)
101 ; 2 = HL7
102 ; 3 = CDC (not applicable for Collection Method)
103 ; 4 = PTF
104 ;Output: Pointer to file
105 ;Notes : 0 (zero) returned on bad input or if an entry can't be found
106 ;
107 ;Check input
108 S VALUE=$G(VALUE)
109 I VALUE="" Q 0
110 S TYPE=$G(TYPE)
111 S:(TYPE'?1N) TYPE=1
112 S:((TYPE<1)!(TYPE>3)) TYPE=1
113 S CODE=$G(CODE)
114 S:(CODE'?1N) CODE=1
115 S:((CODE<1)!(CODE>4)) CODE=1
116 ;No CDC code for Collection Method
117 I ((TYPE=3)&(CODE=3)) Q 0
118 ;Declare variables
119 N PTR,FILE,NODEREF,PIECE,FOUND
120 S FILE=$S(TYPE=3:$NA(^DIC(10.3)),TYPE=2:$NA(^DIC(10.2)),1:$NA(^DIC(10)))
121 ;Abbreviation and HL7 have x-refs
122 I ((CODE=1)!(CODE=2)) D Q PTR
123 .;Get pointer using x-ref
124 .S NODEREF=$S(CODE=2:"AHL7",1:"C")
125 .S PTR=+$O(@FILE@(NODEREF,VALUE,0))
126 ;CDC and PTF don't have x-refs - loop through file looking for match
127 ;Node & piece code is stored on
128 S NODEREF=0
129 S PIECE=CODE+1
130 S FOUND=0
131 S PTR=0
132 F S PTR=+$O(@FILE@(PTR)) Q:'PTR D Q:FOUND
133 .S NODE=$G(@FILE@(PTR,NODEREF))
134 .I $P(NODE,"^",PIECE)=VALUE S FOUND=1
135 Q PTR
Note: See TracBrowser for help on using the repository browser.