1 | VAFHLPI1 ;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 | ;
|
---|
6 | SEQ3(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 | ;
|
---|
72 | SEQ10(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 | ;
|
---|
126 | SEQ22(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
|
---|