source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQAG02.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: 8.2 KB
Line 
1ACKQAG02 ;DDC/PJU - Module to get data for Audiogram E/E and Transmit to DDC ;07/21/05
2 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;11/01/02
3 ;input: ref to array and DFN
4 ;return: array of VALUES in ACKQARR, ACKQERR if an error was found
5 ;Called by RPC ACKQAUD2
6 ;Used by the the E/E - One Audiogram at a time
7 ;IEN needed in 1st pc for the Enter/edit program
8 ;ACKQARR(1)=audiogram local ien^name of patient^last date seen^tester1^error msg
9 ;ACKQARR(ctr)=pcs in rest of counter nodes
10 ; 1=Xvalue
11 ; 2=ear[L,R]
12 ; 3=
13 ; 4=iAirY
14 ; 5=iAirMask[0-6]-not used in 3*12
15 ; 6=iAirMaskL
16 ; 7=iBoneY
17 ; 8=iBoneMask[0-1]-not used in 3*12
18 ; 9=iBoneMaskL
19 ; 10=IAR
20 ; 11=CAR
21 ; 12=fAirY
22 ; 13=fAirMask[0-6]-not used in 3*12
23 ; 14=fAirMaskL
24 ; 15=fBoneY
25 ; 16=fBoneMask[0-1]-not used in 3*12
26 ; 17=fBoneMaskL
27 ; 18=AR DECAY
28 ; 19=HALF LF
29 ;will return to the Delphi app as subscripted array
30 ;subscripts: 1(gen), 2-13(R), 14-25(L), 26(gen)
31START(ACKQARR,DFN) ;
32 K ACKQERR
33 ;ACKQN is a number counter, S0 is a node holder
34 ;ACKQERR is an error holder
35 ;ACKQFMD hold dates, ACKQ1IEN holds the entry number
36 I '$G(DFN) D G END
37 .S ACKQERR="**ERROR** Must have a DFN to run routine RMPFRPC2 "
38 I '$D(^ACK(509850.9,0)) D G END
39 .S ACKQERR="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file) is not available"
40 ;look up DFN in file
41 I '$D(^ACK(509850.9,"DFN",DFN)) D G END
42 .S ACKQERR="**ERROR** patient not in audiogram file"
43 ;determine if 1 or 2 audiograms - set flag
44 S ACKQFMD="A",ACKQ1IEN=""
45S1 S ACKQFMD=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD),-1)
46 ;set up array for latest one in file
47 I 'ACKQFMD D G END
48 .S ACKQERR="**ERROR** No current audiograms for patient in file"
49 S ACKQIEN=0
50S2 S ACKQIEN=$O(^ACK(509850.9,"DFN",DFN,ACKQFMD,ACKQIEN))
51 I 'ACKQIEN D G S1
52 .S ACKQERR="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQFMD)
53 I '$D(^ACK(509850.9,ACKQIEN,0)) D G S1
54 .S ACKQERR="**ERROR** Node missing in file for this visit"
55 G EN2 ;to skip following line
56EN(ACKQARR,ACKQIEN,DFN) ;
57EN2 ;from S2
58 N ACK,ACKD,ACKDF,ACKT
59 S ACKQARR(1)=0 ;default
60 K ACKQERR F I=2:1:25 S ACKQARR(I)=""
61 S S0=$S(ACKQIEN="":"",1:$G(^ACK(509850.9,ACKQIEN,0))) ;HD63875
62 I S0="" S ACKQFMD="A" G S1 ;HD63875
63 I $P(S0,U,2)'=DFN D G S2 ;should be already checked in calling routine
64 .S ACKQERR="***URGENT ERROR*** File error - wrong DFN in xref DFN or record: "_DFN
65 S DIC=2,DA=DFN,DIQ="AK",DR=".01" D EN^DIQ1 S ACKD=AK(2,DFN,.01) ;DFN name
66 K DIC,DA,DIQ,DR,AK
67 ;(1)=ien^patient^FM date seen^tester
68 S ACKDF=$P(^ACK(509850.9,ACKQIEN,0),U,1)
69 S ACKQARR(1)=ACKQIEN_U_ACKD_U_ACKDF
70 I '$P(S0,U,3) S $P(ACKQARR(1),U,4)="Unknown"
71 E D
72 .S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y) K Y
73 .S $P(ACKQARR(1),U,4)=$P(X,U,1) ;tester name
74 D GETDATA(ACKQIEN)
75END ;if errors, then handle errors and stop
76 S:'$D(ACKQARR(1)) ACKQARR(1)=0
77 I $G(ACKQERR)'="" D D WRTERR ;5th pc of 0 node is err msg
78 .F I=2:1:25 S ACKQARR(I)=""
79 K ACKQERR,ACKQFMD,I,S0
80 Q
81 ;
82GETDATA(ACKQIEN) ;
83 ;input the entry number in the Audiometic Exam Data file (ACKQIEN)
84 ;and current return array subscript value(ACKQN)
85 N ACKQA1,ACKQA2,ACKQA1T,ACKQA2T,ACKQA1L,ACKQA2L ;air initial & repeat values, air tags initial & repeat, air Mask Levels
86 N ACKQB1,ACKQB2,ACKQB1T,ACKQB2T,ACKQB1L,ACKQB2L ;bone initial & repeat values, bone masking init & repeat
87 N P,P1 ;P is the piece of the air nodes, P1 is the piece of the bone nodes
88 N X ;X is the Hz
89 S ACKQN=1 ;counter subscript for array - subsc 1 filled in above
90 ;START R ear
91 ; Air
92 F P=1:1:12 D ;set pcs in ACKQARR node
93 .S ACKQN=ACKQN+1
94 .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:"")
95 .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
96 .S ACKQARR(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y
97 .S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,10)),U,P) ;init Y val
98 .S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,11)),U,P) ;init tag
99 .S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,50)),U,P) ;init tag level
100 .S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,20)),U,P) ;repeat val
101 .S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,21)),U,P) ;repeat tag
102 .S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,51)),U,P) ;repeat tag level
103 .S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T ;default
104 .S $P(ACKQARR(ACKQN),U,6)=ACKQA1L,$P(ACKQARR(ACKQN),U,12)=ACKQA2
105 .S $P(ACKQARR(ACKQN),U,13)=ACKQA2T,$P(ACKQARR(ACKQN),U,14)=ACKQA2L
106 .; bone conduction
107 .I X>125,X<7000 D
108 ..S P1=P-1 ;125 not a bone reading so pc's 1 less
109 ..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,70)),U,P1) ;init bone
110 ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,71)),U,P1) ;init bone TAG
111 ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,90)),U,P1) ;init bone level
112 ..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,75)),U,P1) ;repeat bone
113 ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,76)),U,P1) ;repeat bone TAG
114 ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,91)),U,P1) ;repeat bone mask
115 ..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T
116 ..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2
117 ..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L
118 .;IAR/CAR AR-DECAY AR-HALFLIFE
119 .I (X=500) D
120 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,4)
121 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,8)
122 ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,12)
123 ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,14)
124 .I (X=1000) D
125 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,5)
126 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,9)
127 ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,13)
128 ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,15)
129 .I (X=2000) D
130 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,6)
131 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,10)
132 .I (X=4000) D
133 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,7)
134 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,120)),U,11)
135 ;start L ear
136 ; air
137 F P=1:1:12 D
138 .S ACKQN=ACKQN+1 ;counter subscript for array
139 .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"")
140 .S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000)
141 .S ACKQARR(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y
142 .S ACKQA1=$P($G(^ACK(509850.9,ACKQIEN,30)),U,P) ;initial read null
143 .S ACKQA1T=$P($G(^ACK(509850.9,ACKQIEN,31)),U,P) ;init tag
144 .S ACKQA1L=$P($G(^ACK(509850.9,ACKQIEN,60)),U,P) ;init level
145 .S ACKQA2=$P($G(^ACK(509850.9,ACKQIEN,40)),U,P) ;repeat val
146 .S ACKQA2T=$P($G(^ACK(509850.9,ACKQIEN,41)),U,P) ;repeat tag
147 .S ACKQA2L=$P($G(^ACK(509850.9,ACKQIEN,61)),U,P) ;repeat level
148 .S $P(ACKQARR(ACKQN),U,4)=ACKQA1,$P(ACKQARR(ACKQN),U,5)=ACKQA1T
149 .; bone conduction
150 .I X>125,X<7000 D
151 ..S P1=P-1 ;125 not a bone reading so pc's 1 less
152 ..S ACKQB1=$P($G(^ACK(509850.9,ACKQIEN,80)),U,P1) ;init val
153 ..S ACKQB1T=$P($G(^ACK(509850.9,ACKQIEN,81)),U,P1) ;init tag
154 ..S ACKQB1L=$P($G(^ACK(509850.9,ACKQIEN,100)),U,P1) ;init mask level
155 ..S ACKQB2=$P($G(^ACK(509850.9,ACKQIEN,85)),U,P1) ;repeat val
156 ..S ACKQB2T=$P($G(^ACK(509850.9,ACKQIEN,86)),U,P1) ;repeat tag
157 ..S ACKQB2L=$P($G(^ACK(509850.9,ACKQIEN,101)),U,P1) ;repeat mask level
158 ..S $P(ACKQARR(ACKQN),U,7)=ACKQB1,$P(ACKQARR(ACKQN),U,8)=ACKQB1T ;default
159 ..S $P(ACKQARR(ACKQN),U,9)=ACKQB1L,$P(ACKQARR(ACKQN),U,15)=ACKQB2
160 ..S $P(ACKQARR(ACKQN),U,16)=ACKQB2T,$P(ACKQARR(ACKQN),U,17)=ACKQB2L
161 .; IAR/CAR AR-DECAY AR-HALFLIFE
162 .I (X=500) D
163 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,4)
164 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,8)
165 ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12)
166 ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14)
167 .I (X=1000) D
168 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,5)
169 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,9)
170 ..S $P(ACKQARR(ACKQN),U,18)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,12)
171 ..S $P(ACKQARR(ACKQN),U,19)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,14)
172 .I (X=2000) D
173 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,6)
174 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,10)
175 .I (X=4000) D
176 ..S $P(ACKQARR(ACKQN),U,10)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,7)
177 ..S $P(ACKQARR(ACKQN),U,11)=$P($G(^ACK(509850.9,ACKQIEN,121)),U,11)
178 Q
179 ;
180WRTERR ;
181 I $L($G(ACKQERR)) D
182 .S $P(ACKQARR(1),U,5)=ACKQERR ;
183 ;W !!,?10,ACKQERR ;used for direct call testing
184 Q
Note: See TracBrowser for help on using the repository browser.