source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQAG06.m@ 858

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1ACKQAG06 ;DDC/PJU - AUDIOGRAM UTILITY FOR ACKQAG01 ;7/13/05
2 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
3GETDATA(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
21RA 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
36RB .;
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
47RIAR .;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
57RCAR .;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 ;
68LA 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 .;
84LB .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
94LIAR .;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
104LCAR .;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
114SPCH ;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
170SRT ;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
183ITC 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
187REF ;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 ;
195LOGIC(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
217SET1 ;
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
221SET2 ;
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
Note: See TracBrowser for help on using the repository browser.