source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQAG01.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1ACKQAG01 ;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
4START(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
25S1 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
31S2 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
38S3 ;
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
89COM .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)
123E1 ;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
133E2 ;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
165E3 ;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
174E4 ;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
183E5 ;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)
188END ;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
194WRTERR ; 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
199TITLE(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"
205ENDT Q T1_U_T2
Note: See TracBrowser for help on using the repository browser.