1 | ACKQAG01 ;DDC/PJU - Get data for Audiogram(s) Display from 509850.9 ;07/13/05
|
---|
2 | ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
|
---|
3 | ;input: ref to array and DFN. See ACKQAG.txt for information
|
---|
4 | START(ACKQARR,DFN,IEN) ;;array name(.reference) and pointer to Patient file (#2)
|
---|
5 | ;include IEN in 509850.9 if specific one, otherwise put 0 for last one
|
---|
6 | ; see ACKQAG.txt for descriptions
|
---|
7 | K ACKQARR ;make sure it starts empty
|
---|
8 | N ACKT,BD,CL,S0,S1,SSN,TD,TT,TU,J2
|
---|
9 | S (ACKQARR(0),ACKI,ACKQ)=0
|
---|
10 | S ACKQERR="" F X=1:1:33 S ACKQARR(X)=""
|
---|
11 | I '$D(^ACK(509850.9,0)) D G END
|
---|
12 | .S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
|
---|
13 | I '$G(DFN) D G END
|
---|
14 | .S ACKQERR="**ERROR** Must have a DFN for Display "
|
---|
15 | I '$D(^ACK(509850.9,"DFN",DFN)) D G END
|
---|
16 | .S ACKQERR="**ERROR** patient not in audiogram file"
|
---|
17 | D DEM^VADPT ; - demographic variables
|
---|
18 | I $G(VAERR) S ACKQERR="**ERROR** Problem in retrieving Demographic values" G END
|
---|
19 | S SSN=$P(VADM(2),U,1),BD=VADM(3)
|
---|
20 | S ACKQDAT="A",ACKQ1IEN=""
|
---|
21 | I $G(IEN) D G S3
|
---|
22 | .S (ACKQ1IEN,ACKQI)=IEN
|
---|
23 | .S ACKQDAT=$P($G(^ACK(509850.9,IEN,0)),U,1)
|
---|
24 | .S ACKQ=1
|
---|
25 | S1 S ACKQDAT=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT),-1) ;get last IEN
|
---|
26 | I 'ACKQ,'ACKQDAT D G END
|
---|
27 | .S ACKQERR="**ERROR** No current audiograms for patient in file"
|
---|
28 | I ACKQ=1,'ACKQDAT G E1 ;only 1
|
---|
29 | I ACKQ>0 S ACKI=ACKI+1 ;
|
---|
30 | S ACKQI=0
|
---|
31 | S2 S ACKQI=$O(^ACK(509850.9,"DFN",DFN,ACKQDAT,ACKQI))
|
---|
32 | I 'ACKQ,'ACKQI G S1
|
---|
33 | G:'ACKQI S1
|
---|
34 | ;W !,"Entry number found: ",ACKQI ;for testing
|
---|
35 | I '$D(^ACK(509850.9,ACKQI,0)) D G END
|
---|
36 | .S ACKQERR="**ERROR** Node missing in file for this visit"
|
---|
37 | S ACKQ=ACKQ+1 ;set flag # of Auds
|
---|
38 | S3 ;
|
---|
39 | S S0=$G(^ACK(509850.9,ACKQI,0))
|
---|
40 | I $P(S0,U,2)'=DFN D G END
|
---|
41 | .S ACKQERR="***URGENT** Actual Patient in Exam File entry:"_ACKQI_" is different than DFN cross-ref, notify IRM"
|
---|
42 | I ACKQ=1 D G:'$G(IEN) S2 G:$G(IEN) E1
|
---|
43 | .S ACKQ1IEN=ACKQI,TD=$P(S0,U,1)
|
---|
44 | .S X=$P($$FMTE^XLFDT(TD),"@",1)
|
---|
45 | .S ACKQARR(0)=1_U_VADM(1)_U_X ;initial setup
|
---|
46 | .I $P(S0,U,3) D ;DUZ of tester
|
---|
47 | ..S TU=$P(S0,U,3) D:TU>0
|
---|
48 | ...S TT=$$TITLE(TU)
|
---|
49 | ...S $P(ACKQARR(0),U,4)=$P(TT,U,1) ;tester1 name
|
---|
50 | ...S $P(ACKQARR(0),U,6)=$P(TT,U,2) ;title
|
---|
51 | .S $P(ACKQARR(0),U,5)=$P(S0,U,5) ;DFN age
|
---|
52 | .S $P(ACKQARR(0),U,7)=SSN
|
---|
53 | .S S1=$P(S0,U,10) D:S1
|
---|
54 | ..K AK S DIC=4,DA=S1,DIQ="AK",DR=".01" D EN^DIQ1 ;
|
---|
55 | ..S $P(ACKQARR(33),U,12)=AK(4,S1,.01) ;Sta name
|
---|
56 | ..K AK,DIC,DA,DIQ,DR
|
---|
57 | .S CL=$P(S0,U,14)
|
---|
58 | .S $P(ACKQARR(33),U,11)=CL ;claim #
|
---|
59 | .D GETDATA^ACKQAG06(ACKQI,.ACKI) ;fill air/bone & other nodes
|
---|
60 | .S ACKT=ACKQ1IEN ;fill (26)
|
---|
61 | .S S0=$G(^ACK(509850.9,ACKT,120)) ;R AI node
|
---|
62 | .F X=1:1:15 S $P(ACKQARR(26),U,X)=$P(S0,U,X)
|
---|
63 | .;PUT R EAR BBNs * IMMIT 678 HERE *****
|
---|
64 | .S $P(ACKQARR(26),U,31)=$P(S0,U,17) ;R IAR BBN
|
---|
65 | .S $P(ACKQARR(26),U,32)=$P(S0,U,18) ;R CAR BBN
|
---|
66 | .S $P(ACKQARR(26),U,33)=$P(S0,U,19) ;R PkIm678
|
---|
67 | .S S0=$G(^ACK(509850.9,ACKT,121)) ;L AI node
|
---|
68 | .F X=1:1:15 S $P(ACKQARR(26),U,(X+15))=$P(S0,U,X)
|
---|
69 | .;PUT L EAR BBNs * IMMIT 678 HERE ***
|
---|
70 | .S $P(ACKQARR(26),U,34)=$P(S0,U,17) ;L IAR BBN
|
---|
71 | .S $P(ACKQARR(26),U,35)=$P(S0,U,18) ;L CAR BBN
|
---|
72 | .S $P(ACKQARR(26),U,36)=$P(S0,U,19) ;L PkIm678
|
---|
73 | .;Modify (24) 12000 not used in 2364 display or 2364
|
---|
74 | .S S0=$G(^ACK(509850.9,ACKT,110)),J=4 ;R speech
|
---|
75 | .F X=6:5:26 D ;6,11,16,21,26
|
---|
76 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev R
|
---|
77 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;mask lev R
|
---|
78 | .S S0=$G(^ACK(509850.9,ACKT,111)) ;L speech
|
---|
79 | .F X=6:5:26 D ;6,11,16,21,26
|
---|
80 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X) ;pre lev L
|
---|
81 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,(X+1)) ;mask lev L
|
---|
82 | .S S0=$G(^ACK(509850.9,ACKT,1)),J=24
|
---|
83 | .F X=5,3,1 D ;R AVG'S 4,3,2
|
---|
84 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X)
|
---|
85 | .F X=6,4,2 D ;L AVG'S 4,3,2
|
---|
86 | ..S J=J+1,$P(ACKQARR(24),U,J)=$P(S0,U,X)
|
---|
87 | .S $P(ACKQARR(33),U,9)=$P(S0,U,11) ;TYMP TYPE R
|
---|
88 | .S $P(ACKQARR(33),U,10)=$P(S0,U,12) ;TYMP TYPE L
|
---|
89 | COM .F X=30,31,32 S ACKQARR(X)="" ;COMMENTS LINES
|
---|
90 | .I $D(^ACK(509850.9,ACKT,122)) S X1="" D
|
---|
91 | ..Q:'$D(^ACK(509850.9,ACKT,122,1,0)) S X1=$G(^(0))
|
---|
92 | ..I $L(X1) D
|
---|
93 | ...S ACKQARR(30)=$E(X1,1,110),X1=$E(X1,111,350)
|
---|
94 | ...S:$L(X1) ACKQARR(31)=$E(X1,1,110)_" ",X1=$E(X1,111,350)
|
---|
95 | ...S:$L(X1) ACKQARR(32)=$E(X1,1,110)_" "
|
---|
96 | ..Q:$L(ACKQARR(32))>105
|
---|
97 | ..Q:'$D(^ACK(509850.9,ACKT,122,2,0)) S X1=$G(^(0))
|
---|
98 | ..I $L(X1) D
|
---|
99 | ...S Z1=$L(ACKQARR(30))
|
---|
100 | ...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
101 | ...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
|
---|
102 | ....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
103 | ...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<110 D
|
---|
104 | ....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
|
---|
105 | ..Q:$L(ACKQARR(32))>105
|
---|
106 | ..Q:'$D(^ACK(509850.9,ACKT,122,3,0)) S X1=$G(^(0))
|
---|
107 | ..I $L(X1) D
|
---|
108 | ...S Z1=$L(ACKQARR(30))
|
---|
109 | ...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
110 | ...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
|
---|
111 | ....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
112 | ...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<108 D
|
---|
113 | ....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
|
---|
114 | ..Q:$L(ACKQARR(32))>105
|
---|
115 | ..Q:'$D(^ACK(509850.9,ACKT,122,4,0)) S X1=$G(^(0))
|
---|
116 | ..I $L(X1) D
|
---|
117 | ...S Z1=$L(ACKQARR(30))
|
---|
118 | ...I Z1<108 S ACKQARR(30)=ACKQARR(30)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
119 | ...S Z1=$L(ACKQARR(31)) I Z1<108,$L(X1) D
|
---|
120 | ....S ACKQARR(31)=ACKQARR(31)_$E(X1,1,110-Z1)_" ",X1=$E(X1,111-Z1,350)
|
---|
121 | ...S Z1=$L(ACKQARR(32)) I $L(X1),Z1<108 D
|
---|
122 | ....S ACKQARR(32)=ACKQARR(32)_$E(X1,1,110-Z1)
|
---|
123 | E1 ;for patch 12 add fin readings for display 2364
|
---|
124 | ;sub retest for fin if fin="" for table
|
---|
125 | S S0=$G(^ACK(509850.9,ACKT,20)) ;fin A test R
|
---|
126 | S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
|
---|
127 | S S0=$G(^ACK(509850.9,ACKT,75)) ;fin B test R
|
---|
128 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
|
---|
129 | S S0=$G(^ACK(509850.9,ACKT,40)) ;fin A test L
|
---|
130 | F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
|
---|
131 | S S0=$G(^ACK(509850.9,ACKT,85)) ;fin B test L
|
---|
132 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(12),U,J)=X
|
---|
133 | E2 ;for patch 12 add init readings for disp of 2364
|
---|
134 | S S0=$G(^ACK(509850.9,ACKT,10)) ;1 air test R
|
---|
135 | S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
|
---|
136 | S S0=$G(^ACK(509850.9,ACKT,70)) ;1 bone test R
|
---|
137 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
|
---|
138 | ;
|
---|
139 | S S0=$G(^ACK(509850.9,ACKT,15)) ;retest A R
|
---|
140 | S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1 D:(X'="")
|
---|
141 | .I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for init R A
|
---|
142 | .E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
|
---|
143 | .E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
|
---|
144 | S S0=$G(^ACK(509850.9,ACKT,72)) ;retest bone R
|
---|
145 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1 D:(X'="")
|
---|
146 | .I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for init R B
|
---|
147 | .E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
|
---|
148 | .E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
|
---|
149 | S J2=J ;save j for start of L
|
---|
150 | S S0=$G(^ACK(509850.9,ACKT,30)) ;1st A test L
|
---|
151 | F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
|
---|
152 | S S0=$G(^ACK(509850.9,ACKT,80)) ;1st B test L
|
---|
153 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(27),U,J)=X
|
---|
154 | S J=J2 ;reset j to start of L ear & sub
|
---|
155 | S S0=$G(^ACK(509850.9,ACKT,35)) ;retest A L
|
---|
156 | F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1 D:(X'="")
|
---|
157 | .I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for 1st L A
|
---|
158 | .E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
|
---|
159 | .E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
|
---|
160 | S S0=$G(^ACK(509850.9,ACKT,82)) ;retest B L
|
---|
161 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1 D:(X'="")
|
---|
162 | .I $P(ACKQARR(27),U,J)="" S $P(ACKQARR(27),U,J)=X ;sub for 1st L B
|
---|
163 | .E I $P(ACKQARR(27),U,J)["+",X'["+" S $P(ACKQARR(27),U,J)=X
|
---|
164 | .E I X<$P(ACKQARR(27),U,J) S $P(ACKQARR(27),U,J)=X
|
---|
165 | E3 ;for patch 12 add init tag for disp of 2364
|
---|
166 | S S0=$G(^ACK(509850.9,ACKT,11)) ;1st A tag R
|
---|
167 | S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
|
---|
168 | S S0=$G(^ACK(509850.9,ACKT,71)) ;1st B tag R
|
---|
169 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
|
---|
170 | S S0=$G(^ACK(509850.9,ACKT,31)) ;1st A tag L
|
---|
171 | F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
|
---|
172 | S S0=$G(^ACK(509850.9,ACKT,81)) ;1st B tag L
|
---|
173 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(28),U,J)=X
|
---|
174 | E4 ;for patch 12 add final tag for display of 2364
|
---|
175 | S S0=$G(^ACK(509850.9,ACKT,21)) ;final A tag R
|
---|
176 | S J=0 F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
|
---|
177 | S S0=$G(^ACK(509850.9,ACKT,76)) ;final B tag R
|
---|
178 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
|
---|
179 | S S0=$G(^ACK(509850.9,ACKT,41)) ;final A tag L
|
---|
180 | F P=2,3,5:1:11 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
|
---|
181 | S S0=$G(^ACK(509850.9,ACKT,86)) ;final B tag L
|
---|
182 | F P=1,2,4:1:8 S X=$P(S0,U,P),J=J+1,$P(ACKQARR(29),U,J)=X
|
---|
183 | E5 ;for patch 12 add OTHER TESTS score values
|
---|
184 | S S0=$G(^ACK(509850.9,ACKT,120)) ;Oth Tests R
|
---|
185 | F P=1:1:4 S $P(ACKQARR(33),U,P)=$P(S0,U,P+19)
|
---|
186 | S S0=$G(^ACK(509850.9,ACKT,121)) ;Oth Tests L
|
---|
187 | F P=1:1:4 S $P(ACKQARR(33),U,P+4)=$P(S0,U,P+19)
|
---|
188 | END ;if 0-1 charts and errors, then kill 1st, & pass error
|
---|
189 | I $G(ACKQERR)'="",$G(ACKQ)=1 D D WRTERR
|
---|
190 | .S $P(ACKQARR(0),U,1)=0 F J=3:1:11 S $P(ACKQARR(0),U,J)=""
|
---|
191 | .F ACKI=1:1:33 S ACKQARR(ACKI)=""
|
---|
192 | K ACKI,ACKQERR,ACKQDAT,ACKQ,ACKQI,ACKQ1IEN,J,X
|
---|
193 | Q
|
---|
194 | WRTERR ; Record error & write out if testing
|
---|
195 | I $L($G(ACKQERR)) D
|
---|
196 | .;W !!,?10,ACKQERR ;direct call testing
|
---|
197 | .S $P(ACKQARR(0),U,8)=ACKQERR ;error for displ in Delphi
|
---|
198 | Q
|
---|
199 | TITLE(ACKUSER) ;input DUZ returns printable name and title
|
---|
200 | N T1,T2,ACK,DIC,DA,DR,DIQ S (T1,T2)="Unknown" G:'$G(ACKUSER) ENDT
|
---|
201 | S DIC=200,DA=ACKUSER,DIQ="ACK",DR=".01;8" D EN^DIQ1
|
---|
202 | S T1=$G(ACK(200,ACKUSER,.01))
|
---|
203 | S T2=$G(ACK(200,ACKUSER,8))
|
---|
204 | S:T1="" T1="Unknown" S:T2="" T2="Unknown"
|
---|
205 | ENDT Q T1_U_T2
|
---|