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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1VAFHLPI1 ;BPFO/JRP - EXTENSION OF PID SEGMENT BUILDER VAFHLPID;5-DEC-2001 ; 21 Nov 2002 3:13 PM
2 ;;5.3;Registration;**415**;Aug 13, 1993
3 ;
4 Q
5 ;
6SEQ3(DFN,TYPE,HLENC,HLQ) ;Build specified Patient ID (seq 3)
7 ;Input : DFN - Pointer to Patient file (#2)
8 ; TYPE - Which Patient ID to build
9 ; NI = ICN (default)
10 ; SS = SSN [with dashes]
11 ; PI = DFN
12 ; HLENC - HL7 encoding characters (defaults to ~|\&)
13 ; HLQ - HL7 null designation (defaults to "")
14 ;Output : Value for Patient ID (seq 3)
15 ;Notes : HLQ will be returned on bad input
16 ;
17 ;Check input
18 S HLENC=$G(HLENC)
19 S:$L(HLENC)'=4 HLENC="~|\&"
20 S:'$D(HLQ) HLQ=""""""
21 S DFN=+$G(DFN)
22 I '$D(^DPT(DFN,0)) Q HLQ
23 S TYPE=$G(TYPE,"NI")
24 S:(",NI,SS,PI,"'[(","_TYPE_",")) TYPE="NI"
25 ;Declare variables
26 N COMP,REP,SUB,VALUE,ID,TMP
27 ;Break out encoding characters
28 S COMP=$E(HLENC,1)
29 S REP=$E(HLENC,2)
30 S SUB=$E(HLENC,4)
31 ;ID (comp 1)
32 S ID=""
33 ;ICN
34 I TYPE="NI" D
35 .;Don't transmit local ICNs
36 .I $$IFLOCAL^MPIF001(DFN) S ID="" Q
37 .S ID=$$GETICN^MPIF001(DFN)
38 .I (+ID)=-1 S ID=""
39 ;SSN
40 I TYPE="SS" D
41 .S ID=$P($G(^DPT(DFN,0)),"^",9)
42 .I ID'="" S ID=$E(ID,1,3)_"-"_$E(ID,4,5)_"-"_$E(ID,6,10)
43 ;DFN
44 I TYPE="PI" D
45 .S ID=DFN
46 S VALUE=$S(ID="":HLQ,1:ID)
47 ;Check Digit (comp 2) - not used for SSN
48 I TYPE'="SS" D
49 .;ICN - pull off check digit
50 .I TYPE="NI" S $P(VALUE,COMP,2)=$P(ID,"V",2) Q
51 .;DFN - calculate check digit
52 .; Note: output of call includes Check Digit Scheme (comp 3)
53 .S TMP=$$M10^HLFNC(DFN,COMP)
54 .S $P(VALUE,COMP,2,3)=$P(TMP,COMP,2,3)
55 ;Assigning Authority (comp 4)
56 S TMP=""
57 S $P(TMP,SUB,1)=$S(TYPE="SS":"USSSA",1:"USVHA")
58 S $P(TMP,SUB,3)="L"
59 S $P(VALUE,COMP,4)=TMP
60 ;Identifier Type Code (comp 5)
61 S $P(VALUE,COMP,5)=TYPE
62 ;Assigning Facility (comp 6) - only used for DFN
63 I TYPE="PI" S $P(VALUE,COMP,6)=+$P($$SITE^VASITE(),"^",3)
64 ;Effective Date (comp 7) - only used for DFN
65 I TYPE="PI" D
66 .;DFN
67 .S TMP=$P($G(^DPT(DFN,0)),"^",16)
68 .S $P(VALUE,COMP,7)=$$HLDATE^HLFNC(TMP,"DT")
69 ;Return value
70 Q VALUE
71 ;
72SEQ10(HOW,HLQ) ;Race
73 ;Input : HOW - Qualifiers denoting how & which race to return
74 ; N = Return new race value (2.02 multiple)
75 ; T = Include text (components 2 & 5)
76 ; B = Include second triplet (components 4 - 6)
77 ; "" = Return historical value (.06 field)
78 ; HLQ - HL7 null designation
79 ;Assumed: VADM() - Output of call to DEM^VADPT
80 ;Output : None - sets nodes in array VAFY
81 ; VAFY(10,1..X) = Repetion X (if no components)
82 ; VAFY(10,1..X,1..Y) = Component Y of repetiton X
83 ;Notes : Validity and existance of input is assumed
84 ; : Use of T & B qualifiers assume use of N qualifier
85 ; : Assumes no individual component is greater than 245
86 ; characters long
87 ;
88 ;Declare variables
89 N RACENUM,CNT,RACE,X
90 K VAFY(10)
91 I (HOW="")!((HOW'["N")&(HOW'["B")&(HOW'["T")) D Q
92 .;Send historical value (if blank, send 7 (UNKNOWN))
93 .S X=$$PTR2CODE^DGUTL4(+VADM(8),1,1)
94 .S VAFY(10,1)=$S(X]"":X,1:7)
95 ;No values on file
96 I VADM(12)=0 D Q
97 .;First triplet
98 .S VAFY(10,1,1)=HLQ
99 .S VAFY(10,1,2)=$S(HOW["T":HLQ,1:"")
100 .S VAFY(10,1,3)="0005"
101 .;Second triplet
102 .Q:HOW'["B"
103 .S VAFY(10,1,4)=HLQ
104 .S VAFY(10,1,5)=$S(HOW["T":HLQ,1:"")
105 .S VAFY(10,1,6)="CDC"
106 ;Loop through all races (CNT is repetition location)
107 S RACENUM=0
108 F CNT=1:1 S RACENUM=+$O(VADM(12,RACENUM)) Q:'RACENUM D
109 .;Fabricate race value -> RACE-METHOD
110 .S RACE=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,2)
111 .S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,RACENUM,1)),3,2)
112 .S:X="" X="UNK"
113 .S RACE=RACE_"-"_X
114 .;First triplet
115 .S VAFY(10,CNT,1)=RACE
116 .S VAFY(10,CNT,2)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
117 .S VAFY(10,CNT,3)="0005"
118 .;Second triplet
119 .Q:HOW'["B"
120 .S X=$$PTR2CODE^DGUTL4(+VADM(12,RACENUM),1,3)
121 .S VAFY(10,CNT,4)=$S(X="":HLQ,1:X)
122 .S VAFY(10,CNT,5)=$S(HOW["T":$P(VADM(12,RACENUM),"^",2),1:"")
123 .S VAFY(10,CNT,6)="CDC"
124 Q
125 ;
126SEQ22(HOW,HLQ) ;Ethnicity
127 ;Input : HOW - Qualifiers denoting how to return ethnicity
128 ; T = Include text (components 2 & 5)
129 ; B = Include second triplet (components 4 - 6)
130 ; "" = Only return components 1 & 3
131 ; HLQ - HL7 null designation
132 ;Assumed: VADM() - Output of call to DEM^VADPT
133 ;Output : None - sets nodes in array VAFY
134 ; VAFY(22,1,1..Y) = Component Y
135 ;Notes : Validity and existance of input is assumed
136 ; : Assumes no individual component is greater than 245
137 ; characters long
138 ;
139 ;Declare variables
140 N ETHNIC,X,ETHNUM,CNT
141 K VAFY(22)
142 ;No value on file
143 I +VADM(11)=0 D Q
144 .;First triplet
145 .S VAFY(22,1,1)=HLQ
146 .S VAFY(22,1,2)=$S(HOW["T":HLQ,1:"")
147 .S VAFY(22,1,3)="0189"
148 .;Second triplet
149 .Q:HOW'["B"
150 .S VAFY(22,1,4)=HLQ
151 .S VAFY(22,1,5)=$S(HOW["T":HLQ,1:"")
152 .S VAFY(22,1,6)="CDC"
153 ;Loop through all ethnicities (CNT is repetition location)
154 S ETHNUM=0
155 F CNT=1:1 S ETHNUM=+$O(VADM(11,ETHNUM)) Q:'ETHNUM D
156 .;Fabricate ethnicity value -> ETHNICITY-METHOD
157 .S ETHNIC=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,2)
158 .S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,ETHNUM,1)),3,2)
159 .S:X="" X="UNK"
160 .S ETHNIC=ETHNIC_"-"_X
161 .;First triplet
162 .S VAFY(22,CNT,1)=ETHNIC
163 .S VAFY(22,CNT,2)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
164 .S VAFY(22,CNT,3)="0189"
165 .;Second triplet
166 .Q:HOW'["B"
167 .S X=$$PTR2CODE^DGUTL4(+VADM(11,ETHNUM),2,3)
168 .S VAFY(22,CNT,4)=$S(X="":HLQ,1:X)
169 .S VAFY(22,CNT,5)=$S(HOW["T":$P(VADM(11,ETHNUM),"^",2),1:"")
170 .S VAFY(22,CNT,6)="CDC"
171 Q
Note: See TracBrowser for help on using the repository browser.