1 | ACKQAG06 ;DDC/PJU - AUDIOGRAM UTILITY FOR ACKQAG01 ;7/13/05
|
---|
2 | ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
|
---|
3 | GETDATA(ACKQI,ACKI) ;called from ACKQAG01- Puts values in ACKQARR()
|
---|
4 | ;input the entry number in the Audiometic Exam Data file (ACKQI)
|
---|
5 | ;and current return array subscript value by reference(.ACKI)
|
---|
6 | ;ACKQA1=air initial threshold
|
---|
7 | ;ACKQA2=air REPEAT THRESHOLD
|
---|
8 | ;ACKQA3=air FINAL THRESHOLD
|
---|
9 | ;ACKQAML=AIR MASK LEVEL
|
---|
10 | ;ACKQB1=bone initial threshold
|
---|
11 | ;ACKQB2=bone REPEAT THRESHOLD
|
---|
12 | ;ACKQB3=bone FINAL THRESHOLD
|
---|
13 | ;ACKQBML=bone MASK level
|
---|
14 | ;P=piece of the air nodes, P1=piece of the bone nodes
|
---|
15 | ;SB=Bone node, X is the Hz reading to start and then a string holding variable
|
---|
16 | ;X1 is a string holding variable, I is an integer used for looping
|
---|
17 | ;S0 is a node holder
|
---|
18 | N ACKQA1,ACKQA2,ACKQA3,ACKQAML
|
---|
19 | N ACKQB1,ACKQB2,ACKQB3,ACKQBML
|
---|
20 | N I,P,P1,S0,SB,X,X1
|
---|
21 | RA F P=1:1:12 D ;R ear Air
|
---|
22 | .S (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""
|
---|
23 | .S ACKI=ACKI+1 ;counter subscript for array
|
---|
24 | .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")
|
---|
25 | .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
|
---|
26 | .S ACKQARR(ACKI)=X_U_ACKQI_U_"R"_U Q:ACKI=12 ;12 node used for repeat test data
|
---|
27 | .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,10)),U,P) ;init val
|
---|
28 | .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,15)),U,P) ;RETEST val
|
---|
29 | .S ACKQA3=$P($G(^ACK(509850.9,ACKQI,20)),U,P) ;FINAL val
|
---|
30 | .S ACKQAML=$P($G(^ACK(509850.9,ACKQI,51)),U,P) ;MASK level
|
---|
31 | .S:ACKQAML="CNM" ACKQAML=""
|
---|
32 | .S $P(ACKQARR(ACKI),U,4)="" ;default air Y
|
---|
33 | .S $P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete
|
---|
34 | .S $P(ACKQARR(ACKI),U,6)="" ;default mask level
|
---|
35 | .D LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A") ;Air Conduction
|
---|
36 | RB .;
|
---|
37 | .I X>125,X<7000 D ;R bone conduction
|
---|
38 | ..S P1=P-1 ;125 not a bone reading so pc's 1 less
|
---|
39 | ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,70)),U,P1) ;init bone
|
---|
40 | ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,72)),U,P1) ;RETEST bone
|
---|
41 | ..S ACKQB3=$P($G(^ACK(509850.9,ACKQI,75)),U,P1) ;FINAL bone
|
---|
42 | ..S ACKQBML=$P($G(^ACK(509850.9,ACKQI,91)),U,P1) ;bone MASK level
|
---|
43 | ..S $P(ACKQARR(ACKI),U,7)="" ;default bone Y
|
---|
44 | ..S $P(ACKQARR(ACKI),U,8)="" ;default mask *** obsolete
|
---|
45 | ..S $P(ACKQARR(ACKI),U,9)="" ;default mask level
|
---|
46 | ..D LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B") ;bone conduction rules
|
---|
47 | RIAR .;IAR R
|
---|
48 | .S SB=$G(^ACK(509850.9,ACKQI,120))
|
---|
49 | .I (X=500) D
|
---|
50 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) ;R IAR500
|
---|
51 | .E I (X=1000) D
|
---|
52 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) ;R IAR1000
|
---|
53 | .E I (X=2000) D
|
---|
54 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) ;R IAR2000
|
---|
55 | .E I (X=4000) D
|
---|
56 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) ;R IAR4000
|
---|
57 | RCAR .;CAR
|
---|
58 | .S SB=$G(^ACK(509850.9,ACKQI,121))
|
---|
59 | .I (X=500) D
|
---|
60 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) ;R CAR500
|
---|
61 | .E I (X=1000) D
|
---|
62 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) ;R CAR1000
|
---|
63 | .E I (X=2000) D
|
---|
64 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) ;R CAR2000
|
---|
65 | .E I (X=4000) D
|
---|
66 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) ;R CAR4000
|
---|
67 | ;
|
---|
68 | LA F P=1:1:12 D ;L ear air
|
---|
69 | .S (ACKQA1,ACKQA2,ACKQA3,ACKQAML,ACKQB1,ACKQB2,ACKQB3,ACKQBML)=""
|
---|
70 | .S ACKI=ACKI+1 ;counter subscript for array
|
---|
71 | .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,P=7:2000,1:"")
|
---|
72 | .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
|
---|
73 | .S ACKQARR(ACKI)=X_U_ACKQI_U_"L"_U Q:ACKI=24 ;24 node used for speech test data
|
---|
74 | .S ACKQA1=$P($G(^ACK(509850.9,ACKQI,30)),U,P) ;init val
|
---|
75 | .S ACKQA2=$P($G(^ACK(509850.9,ACKQI,35)),U,P) ;RETEST val
|
---|
76 | .S ACKQA3=$P($G(^ACK(509850.9,ACKQI,40)),U,P) ;FINAL val
|
---|
77 | .S ACKQAML=$P($G(^ACK(509850.9,ACKQI,61)),U,P) ;MASK level
|
---|
78 | .S:ACKQAML="CNM" ACKQAML=""
|
---|
79 | .S $P(ACKQARR(ACKI),U,4)="" ;default air Y
|
---|
80 | .S $P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete
|
---|
81 | .S $P(ACKQARR(ACKI),U,6)="" ;default mask level
|
---|
82 | .D LOGIC(ACKQA1,ACKQA2,ACKQA3,ACKQAML,"A") ;Air Conduction
|
---|
83 | .;
|
---|
84 | LB .I X>125,X<7000 D ;L bone conduction
|
---|
85 | ..S P1=P-1 ;125 not a bone reading so pc's 1 less
|
---|
86 | ..S ACKQB1=$P($G(^ACK(509850.9,ACKQI,80)),U,P1) ;init bone
|
---|
87 | ..S ACKQB2=$P($G(^ACK(509850.9,ACKQI,82)),U,P1) ;RETEST bone
|
---|
88 | ..S ACKQB3=$P($G(^ACK(509850.9,ACKQI,85)),U,P1) ;FINAL bone
|
---|
89 | ..S ACKQBML=$P($G(^ACK(509850.9,ACKQI,101)),U,P1) ;bone MASK level
|
---|
90 | ..S $P(ACKQARR(ACKI),U,7)="" ;default bone Y
|
---|
91 | ..S $P(ACKQARR(ACKI),U,8)="" ;default mask *** obsolete
|
---|
92 | ..S $P(ACKQARR(ACKI),U,9)="" ;default mask level
|
---|
93 | ..D LOGIC(ACKQB1,ACKQB2,ACKQB3,ACKQBML,"B") ;bone conduction rules
|
---|
94 | LIAR .;IAR L
|
---|
95 | .S SB=$G(^ACK(509850.9,ACKQI,121))
|
---|
96 | .I (X=500) D
|
---|
97 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,4) ;L IAR500
|
---|
98 | .I (X=1000) D
|
---|
99 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,5) ;L IAR1000
|
---|
100 | .I (X=2000) D
|
---|
101 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,6) ;L IAR2000
|
---|
102 | .I (X=4000) D
|
---|
103 | ..S $P(ACKQARR(ACKI),U,10)=$P(SB,U,7) ;L IAR4000
|
---|
104 | LCAR .;CAR L
|
---|
105 | .S SB=$G(^ACK(509850.9,ACKQI,120))
|
---|
106 | .I (X=500) D
|
---|
107 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,8) ;L CAR500
|
---|
108 | .I (X=1000) D
|
---|
109 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,9) ;L CAR1000
|
---|
110 | .I (X=2000) D
|
---|
111 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,10) ;L CAR2000
|
---|
112 | .I (X=4000) D
|
---|
113 | ..S $P(ACKQARR(ACKI),U,11)=$P(SB,U,11) ;L CAR4000
|
---|
114 | SPCH ;next lines are only done 1 time for the table (2364)
|
---|
115 | S ACKI=25 ;25 node- first 10 pc's are word %
|
---|
116 | S S0=$G(^ACK(509850.9,ACKQI,110)) D ;R speech
|
---|
117 | .F I=1:1:5 S $P(ACKQARR(25),U,I)=$P(S0,U,(4+(5*(I-1))))
|
---|
118 | ;S X="" F I=3:5:23 S X=$P(S0,U,I) Q:$L(X)
|
---|
119 | S X=$P(S0,U,3)
|
---|
120 | I $L(X) D
|
---|
121 | .S X1="" I (X=3)!(X=6) S X1="CNC"
|
---|
122 | .I (X=2)!(X=5) S X1="CIDW"
|
---|
123 | .E I (X=1)!(X=4) S X1="NU"
|
---|
124 | .S:X1="" X1="OTHER"
|
---|
125 | .S $P(ACKQARR(25),U,17)=X1 ;MATERIAL R
|
---|
126 | ;S X="" F I=5:5:25 S X=$P(S0,U,I) Q:$L(X)
|
---|
127 | S X=$P(S0,U,5)
|
---|
128 | I $L(X) D
|
---|
129 | .S X1="" I (X=1)!(X=2) S X1="REC"
|
---|
130 | .I (X=3) S X1="MLV"
|
---|
131 | .S $P(ACKQARR(25),U,18)=X1 ;PRES METH R
|
---|
132 | ;
|
---|
133 | S J=20,X="" F I=28:1:32 S X=$P(S0,U,I) D
|
---|
134 | .;S X1=""
|
---|
135 | .;S:X=3 X1="25" S:X=6 X1="50" ;CNC
|
---|
136 | .;S:X=2 X1="25" S:X=5 X1="50" ;W22
|
---|
137 | .;S:X=1 X1="25" S:X=4 X1="50" ;NU
|
---|
138 | .;S:X1=7 X1="OTH"
|
---|
139 | .S J=J+1
|
---|
140 | .S $P(ACKQARR(25),U,J)=X ;LISTS R
|
---|
141 | ;
|
---|
142 | S S0=$G(^ACK(509850.9,ACKQI,111)) D ;L Speech
|
---|
143 | .F I=1:1:5 D
|
---|
144 | ..S J=I+5 S $P(ACKQARR(25),U,J)=$P(S0,U,(4+(5*(I-1))))
|
---|
145 | S X="" F I=3:5:23 S X=$P(S0,U,I) Q:$L(X)
|
---|
146 | I $L(X) D
|
---|
147 | .S X1="" I (X=3)!(X=6) S X1="CNC"
|
---|
148 | .I (X=2)!(X=5) S X1="CIDW"
|
---|
149 | .I (X=1)!(X=4) S X1="NU"
|
---|
150 | .S:X1="" X1="OTHER"
|
---|
151 | .S $P(ACKQARR(25),U,19)=X1 ;Material L if 3*3
|
---|
152 | S X="" F I=5:5:25 S X=$P(S0,U,I) Q:$L(X)
|
---|
153 | I $L(X) D
|
---|
154 | .S X1="" I (X=1)!(X=2) S X1="REC"
|
---|
155 | .E I (X=3) S X1="MLV"
|
---|
156 | .S $P(ACKQARR(25),U,20)=X1 ;PRES METH R
|
---|
157 | ;
|
---|
158 | S J=25 F I=28:1:32 S X=$P(S0,U,I) D
|
---|
159 | .;S X1=""
|
---|
160 | .;S:X=3 X1="25" S:X=6 X1="50" ;CNC
|
---|
161 | .;S:X=2 X1="25" S:X=5 X1="50" ;W22
|
---|
162 | .;S:X=1 X1="25" S:X=4 X1="50" ;NU
|
---|
163 | .;S:X1=7 X1="OTH"
|
---|
164 | .S J=J+1
|
---|
165 | .S $P(ACKQARR(25),U,J)=X ;LISTS L
|
---|
166 | ;
|
---|
167 | S S0=$G(^ACK(509850.9,ACKQI,115))
|
---|
168 | S $P(ACKQARR(25),U,11)=$P(S0,U,9),$P(ACKQARR(25),U,12)=$P(S0,U,11) ;R MAX & PIPB
|
---|
169 | S $P(ACKQARR(25),U,14)=$P(S0,U,12),$P(ACKQARR(25),U,15)=$P(S0,U,14) ;L MAX & PIPB
|
---|
170 | SRT ;next section lines go in array nodes 24 only
|
---|
171 | S $P(ACKQARR(24),U,31)=$P(S0,U,1) ;SRT R1
|
---|
172 | S $P(ACKQARR(24),U,32)=$P(S0,U,2) ;SRT R2
|
---|
173 | S $P(ACKQARR(24),U,35)=$P(S0,U,3) ;R init SRT Mask Lev
|
---|
174 | S $P(ACKQARR(24),U,36)=$P(S0,U,4) ;R final SRT Mask Lev
|
---|
175 | S $P(ACKQARR(24),U,33)=$P(S0,U,5) ;SRT L1
|
---|
176 | S $P(ACKQARR(24),U,34)=$P(S0,U,6) ;SRT L2
|
---|
177 | S $P(ACKQARR(24),U,37)=$P(S0,U,7) ;L init SRT Mask Lev
|
---|
178 | S $P(ACKQARR(24),U,38)=$P(S0,U,8) ;L final SRT Mask Lev
|
---|
179 | S $P(ACKQARR(24),U,39)=$P(S0,U,17) ;R SRT initial tag
|
---|
180 | S $P(ACKQARR(24),U,40)=$P(S0,U,18) ;L SRT initial tag
|
---|
181 | S $P(ACKQARR(24),U,41)=$P(S0,U,15) ;R SRT final tag
|
---|
182 | S $P(ACKQARR(24),U,42)=$P(S0,U,16) ;L SRT final tag
|
---|
183 | ITC S S0=$G(^ACK(509850.9,ACKQI,120)),X=$P(S0,U,16) ;additions to 25 node
|
---|
184 | S $P(ACKQARR(25),U,13)=$S(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"") ;R consistency
|
---|
185 | S SB=$G(^ACK(509850.9,ACKQI,121)),X=$P(SB,U,16)
|
---|
186 | S $P(ACKQARR(25),U,16)=$S(X=1:"GOOD",X=2:"FAIR",X=3:"POOR",1:"") ;L consistency
|
---|
187 | REF ;set referral reason,source & transducer type into node 24
|
---|
188 | S S0=$G(^ACK(509850.9,ACKQI,0)) ;additions to 24 node
|
---|
189 | S $P(ACKQARR(24),U,1)=$P(S0,U,7) ;TYPE OF VISIT
|
---|
190 | S X1="" S X=$P(S0,U,4) I X S X1=$P($G(^SC(X,0)),U,1) ;referral source
|
---|
191 | S $P(ACKQARR(24),U,2)=X1 ;referral source
|
---|
192 | S X1=$P(S0,U,8),$P(ACKQARR(24),U,3)=X1 ;transducer type
|
---|
193 | Q
|
---|
194 | ;
|
---|
195 | LOGIC(R1,R2,R3,ML,AB) ;
|
---|
196 | ;Chart logic:
|
---|
197 | ;R1=init read-R1
|
---|
198 | ;R2=repeat read-R2
|
---|
199 | ;R3=FINAL read-R3
|
---|
200 | ;ML=MASK level-ML
|
---|
201 | ;AB=air or bone
|
---|
202 | ;defaults set above: (BONE IS 7,8,9)
|
---|
203 | ;$P(ACKQARR(ACKI),U,4)="" ;default air Y
|
---|
204 | ;$P(ACKQARR(ACKI),U,5)="" ;default mask *** obsolete
|
---|
205 | ;$P(ACKQARR(ACKI),U,6)="" ;default mask level
|
---|
206 | I (R1="DNT")!(R1="CNT") Q ;leave at "" if not tested
|
---|
207 | I R3'="" D Q ;masked, value in R3 (R3 could contain +)
|
---|
208 | .S:AB="A" $P(ACKQARR(ACKI),U,4)=R3,$P(ACKQARR(ACKI),U,6)=ML
|
---|
209 | .S:AB="B" $P(ACKQARR(ACKI),U,7)=R3,$P(ACKQARR(ACKI),U,9)=ML
|
---|
210 | I R2="" D SET1 Q
|
---|
211 | I R1="" D SET2 Q
|
---|
212 | I R1["+",R2'["+" D SET2 Q
|
---|
213 | I R1'["+",R2["+" D SET1 Q
|
---|
214 | I R1<R2 D SET1 Q
|
---|
215 | E D SET2
|
---|
216 | Q
|
---|
217 | SET1 ;
|
---|
218 | S:AB="A" $P(ACKQARR(ACKI),U,4)=R1,$P(ACKQARR(ACKI),U,6)=ML
|
---|
219 | S:AB="B" $P(ACKQARR(ACKI),U,7)=R1,$P(ACKQARR(ACKI),U,9)=ML
|
---|
220 | Q
|
---|
221 | SET2 ;
|
---|
222 | S:AB="A" $P(ACKQARR(ACKI),U,4)=R2,$P(ACKQARR(ACKI),U,6)=ML
|
---|
223 | S:AB="B" $P(ACKQARR(ACKI),U,7)=R2,$P(ACKQARR(ACKI),U,9)=ML
|
---|
224 | Q
|
---|