source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQAG04.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1ACKQAG04 ;DDC/PJU - Utility for ACKQAG03 - Transmission to DDC;5/16/05
2 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12**;4/01/03
3 ;;see descriptions in ACKQAG.TXT
4START(ACKQA,DFN) ;
5 K ACKQE
6 I '$G(DFN) D G END
7 .S ACKQE="**ERROR** Must have a DFN to run routine RMPFRPC2 "
8 I '$D(^ACK(509850.9,0)) D G END
9 .S ACKQE="**ERROR** QUASAR file 509850.9 (Audiometric Exam Data file)"
10 .S ACKQE=ACKQE_" is not available"
11 I '$D(^ACK(509850.9,"DFN",DFN)) D G END
12 .S ACKQE="**ERROR** patient not in audiogram file"
13 S ACKQDATE="A",ACKQ1IEN=""
14S1 S ACKQDATE=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE),-1)
15 I 'ACKQDATE D G END
16 .S ACKQE="**ERROR** No current audiograms for patient in file"
17 S ACKQ1IEN=0
18S2 S ACKQ1IEN=$O(^ACK(509850.9,"DFN",DFN,ACKQDATE,ACKQ1IEN))
19 I 'ACKQ1IEN D G S1
20 .S ACKQE="**ERROR** No data exists for visit on "_$$FMTE^XLFDT(ACKQDATE)
21 ;W !,"Entry number found: ",ACKQ1IEN
22 I '$D(^ACK(509850.9,ACKQ1IEN,0)) D G S1
23 .S ACKQE="**ERROR** Node missing in file for this visit"
24 G EN2
25EN(ACKQA,ACKQ1IEN,DFN) ;called from ACKQAG03 for data transmission
26EN2 ;entry from S2 to skip EN
27 K ACKQE N SSN,SD,X,NM,DOB,AGE F I=1:1:35 S ACKQA(I)=""
28 S ACKQA(1)=0,ACKQN=0
29 S S0=$G(^ACK(509850.9,ACKQ1IEN,0))
30 I $P(S0,U,2)'=DFN D G END ;already checked in calling routine
31 .S ACKQE="***URGENT AUDIOGRAM FILE ERROR*** wrong DFN"
32 .S ACKQE=ACKQE_" in Cross Reference or record: "_DFN
33 ;Set up ACKQA(1)
34 S SD=$P(S0,U,1) ;DATE SEEN
35 S AGE=$P(S0,U,5)
36 S ACKQA(1)="BGN"_U_ACKQ1IEN
37 D DEM^VADPT I $G(VAERR) D G END
38 .S ACKQE="***UNABLE TO ACCESS PATIENT DEMOGRAPHICS***"
39 D ELIG^VADPT I $G(VAERR) D G END
40 .S ACKQE="***UNABLE TO ACCESS PATIENT ELIGIBILITY***"
41 S NM=VADM(1),NM=$E(NM,1,30),SSN=$P(VADM(2),U,1),DOB=$P(VADM(3),U,1)
42 S $P(ACKQA(1),U,3)=NM
43 S $P(ACKQA(1),U,4)=SSN ;encrypted in ACKQAG03
44 ;;5th pc is for err msg
45 S $P(ACKQA(1),U,6)=DOB
46 I $P(S0,U,3) D ;audiologist
47 .S Y=$P(S0,U,3),X=$$TITLE^ACKQAG01(Y),X=$E($P(X,U,1),1,30)
48 .S $P(ACKQA(1),U,7)=X ;title
49 I '$P(S0,U,3) S $P(ACKQA(1),U,7)="Unknown"
50 S $P(ACKQA(1),U,8)=$P(S0,U,9) ;dt signed
51 S $P(ACKQA(1),U,9)=SD ;FM exam dt
52 S $P(ACKQA(1),U,10)=$S(VAEL(4):"Y",1:"N") ;vet Y/N
53 S $P(ACKQA(1),U,11)=$P(VAEL(6),U,2) ;DFN Type
54 S $P(ACKQA(1),U,12)=AGE
55 S $P(ACKQA(1),U,13)=$P(S0,U,8) ;;transducer type(.08)
56 S $P(ACKQA(1),U,14)=$P(S0,U,14) ;;claim #(.14)
57 S $P(ACKQA(1),U,15)=$P(S0,U,15) ;;retrans dt(.15)
58 D GETDATA(ACKQ1IEN) ;array of test results
59END ;
60 S:'$D(ACKQA(1)) ACKQA(1)=0
61 I $G(ACKQE)'="" D D WRTERR
62 .F I=2:1:39 S:$D(ACKQA(I)) ACKQA(I)=""
63 K ACKQE,ACKQDATE,S0,VADM,VAEL,I
64 Q
65 ;
66GETDATA(ACKQRMI) ;
67 ;;input: entry number in the Audiometic Exam Data file (ACKQRMI)
68 ;;output: set up rest of array ACKQA() subscripts 2-35
69 N P,P1,S0 ;P is the piece of the A nodes,
70 ;P1 is pc of the B nodes, S0 is a node holder
71 N X ;X is the Hz
72 N ACKQN S ACKQN=1 ;counter subscript(ACKQA(1) is filled above)
73 ;subs (2-13) 125-12000 R A & B
74 F P=1:1:12 D ;START R A
75 .S ACKQN=ACKQN+1
76 .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:"")
77 .S:X="" X=$S(P=8:3000,P=9:4000,P=10:6000,P=11:8000,P=12:12000,1:"")
78 .S ACKQA(ACKQN)=X_U_"R"_U_"" ;X^ear^ien^Y
79 .S $P(ACKQA(ACKQN),U,4)=$P($G(^ACK(509850.9,ACKQRMI,10)),U,P) ;1st Y val
80 .S $P(ACKQA(ACKQN),U,5)=$P($G(^ACK(509850.9,ACKQRMI,11)),U,P) ;1st tag(send anyway)
81 .S $P(ACKQA(ACKQN),U,6)=$P($G(^ACK(509850.9,ACKQRMI,50)),U,P) ;1st mask level
82 .S $P(ACKQA(ACKQN),U,12)=$P($G(^ACK(509850.9,ACKQRMI,20)),U,P) ;final val
83 .S $P(ACKQA(ACKQN),U,13)=$P($G(^ACK(509850.9,ACKQRMI,21)),U,P) ;final tag(send anyway)
84 .S $P(ACKQA(ACKQN),U,14)=$P($G(^ACK(509850.9,ACKQRMI,51)),U,P) ;final mask lev
85 .;R B
86 .I X>125,X<7000 D
87 ..S P1=P-1 ;125 not B reading so pc's 1 less
88 ..S $P(ACKQA(ACKQN),U,7)=$P($G(^ACK(509850.9,ACKQRMI,70)),U,P1) ;1st B
89 ..;S $P(ACKQA(ACKQN),U,8)=$P($G(^ACK(509850.9,ACKQRMI,71)),U,P1) ;1st bTAG(send anyway)
90 ..S $P(ACKQA(ACKQN),U,9)=$P($G(^ACK(509850.9,ACKQRMI,90)),U,P1) ;1st mask level
91 ..S $P(ACKQA(ACKQN),U,15)=$P($G(^ACK(509850.9,ACKQRMI,75)),U,P1) ;final B
92 ..;S $P(ACKQA(ACKQN),U,16)=$P($G(^ACK(509850.9,ACKQRMI,76)),U,P1) ;f bTAG(send anyway)
93 ..S $P(ACKQA(ACKQN),U,17)=$P($G(^ACK(509850.9,ACKQRMI,91)),U,P1) ;f B mask
94 .;IAR/CAR AR-DECAY AR-HALFLIFE
95 .S S0=$G(^ACK(509850.9,ACKQRMI,120))
96 .I (X=500) D
97 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) ;R IAR 500
98 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) ;R CAR 500
99 ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) ;R AR decay 500
100 ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) ;R AR HL 500
101 .I (X=1000) D
102 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) ;R IAR 1000
103 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) ;R CAR 1000
104 ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) ;R AR decay 1000
105 ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) ;R AR HL 1000
106 .I (X=2000) D
107 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) ;R IAR 2000
108 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) ;R CAR 2000
109 .I (X=4000) D
110 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) ;R IAR 4000
111 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) ;R CAR 4000
112 ;;subs (14-25) 125-12000 L A&B
113 F P=1:1:12 D ;start L A
114 .S ACKQN=ACKQN+1 ;counter sub for array
115 .S X=$S(P=1:125,P=2:250,P=3:500,P=4:750,P=5:1000,P=6:1500,1:"")
116 .S:X="" X=$S(P=7:2000,P=8:3000,P=9:4000,P=10:6000,P=11:8000,1:12000)
117 .S ACKQA(ACKQN)=X_U_"L"_U_"" ; X^ear^IEN^Y
118 .S $P(ACKQA(ACKQN),U,4)=$P($G(^ACK(509850.9,ACKQRMI,30)),U,P) ;1st value
119 .S $P(ACKQA(ACKQN),U,5)=$P($G(^ACK(509850.9,ACKQRMI,31)),U,P) ;1st tag(lv for now)
120 .S $P(ACKQA(ACKQN),U,6)=$P($G(^ACK(509850.9,ACKQRMI,60)),U,P) ;1st mlev
121 .S $P(ACKQA(ACKQN),U,12)=$P($G(^ACK(509850.9,ACKQRMI,40)),U,P) ;final val
122 .S $P(ACKQA(ACKQN),U,13)=$P($G(^ACK(509850.9,ACKQRMI,41)),U,P) ;f tag(lv for now)
123 .S $P(ACKQA(ACKQN),U,14)=$P($G(^ACK(509850.9,ACKQRMI,61)),U,P) ;f mlev
124 .;L ear bone conduction
125 .I X>125,X<7000 D
126 ..S P1=P-1 ;125 not a bone reading so pc's 1 less
127 ..S $P(ACKQA(ACKQN),U,7)=$P($G(^ACK(509850.9,ACKQRMI,80)),U,P1) ;1st val
128 ..S $P(ACKQA(ACKQN),U,8)=$P($G(^ACK(509850.9,ACKQRMI,81)),U,P1) ;1st tag(lv for now)
129 ..S $P(ACKQA(ACKQN),U,9)=$P($G(^ACK(509850.9,ACKQRMI,100)),U,P1) ;1st mlev
130 ..S $P(ACKQA(ACKQN),U,15)=$P($G(^ACK(509850.9,ACKQRMI,85)),U,P1) ;final val
131 ..S $P(ACKQA(ACKQN),U,16)=$P($G(^ACK(509850.9,ACKQRMI,86)),U,P1) ;f tag(lv for now)
132 ..S $P(ACKQA(ACKQN),U,17)=$P($G(^ACK(509850.9,ACKQRMI,101)),U,P1) ;f mlev
133 .; IAR/CAR AR-DECAY AR-HL
134 .S S0=$G(^ACK(509850.9,ACKQRMI,121))
135 .I (X=500) D
136 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,4) ;L IAR 500
137 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,8) ;L CAR 500
138 ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,12) ;L AR decay 500
139 ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,14) ;L AR HL 500
140 .I (X=1000) D
141 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,5) ;L IAR 1000
142 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,9) ;L CAR 1000
143 ..S $P(ACKQA(ACKQN),U,18)=$P(S0,U,13) ;L AR decay 1000
144 ..S $P(ACKQA(ACKQN),U,19)=$P(S0,U,15) ;L AR HL 1000
145 .I (X=2000) D
146 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,6) ;L IAR 2000
147 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,10) ;L CAR 2000
148 .I (X=4000) D
149 ..S $P(ACKQA(ACKQN),U,10)=$P(S0,U,7) ;L IAR 4000
150 ..S $P(ACKQA(ACKQN),U,11)=$P(S0,U,11) ;L CAR 4000
151 S ACKQN=ACKQN+1 ;sub(26) R Sp
152 S ACKQA(ACKQN)="WDL^R^"_$G(^ACK(509850.9,ACKQRMI,110))
153 S ACKQN=ACKQN+1 ;subscript(27) L Sp
154 S ACKQA(ACKQN)="WDL^L^"_$G(^ACK(509850.9,ACKQRMI,111))
155 S $P(ACKQA(ACKQN),U,1)="WDL",$P(ACKQA(ACKQN),U,2)="L"
156 S ACKQN=ACKQN+1 ;sub(28) R&L PTA,MCL,UCL,tymp type
157 S ACKQA(ACKQN)="PTA^B^"_$G(^ACK(509850.9,ACKQRMI,1))
158 S S0=$G(^ACK(509850.9,ACKQRMI,120)) D ;add 3 pcs to (28)
159 .S $P(ACKQA(ACKQN),U,15)=$P(S0,U,1) ;middle ear pres R
160 .S $P(ACKQA(ACKQN),U,16)=$P(S0,U,2) ;pk immit 226 R
161 .S $P(ACKQA(ACKQN),U,17)=$P(S0,U,16) ;int test consis R
162 S S0=$G(^ACK(509850.9,ACKQRMI,121)) D ;add 3 more pcs to (28)
163 .S $P(ACKQA(ACKQN),U,18)=$P(S0,U,1) ;middle ear pres L
164 .S $P(ACKQA(ACKQN),U,19)=$P(S0,U,2) ;pk immit 226 L
165 .S $P(ACKQA(ACKQN),U,20)=$P(S0,U,16) ;int tst consis L
166 S ACKQN=ACKQN+1 ;sub(29) R&L SRT,PIPB
167 S ACKQA(ACKQN)="SRT^B^"_$G(^ACK(509850.9,ACKQRMI,115)) ;16+2 pcs
168 S ACKQN=ACKQN+1 ;sub(30) R A retest
169 S ACKQA(ACKQN)="RTSTR^R^"_$G(^ACK(509850.9,ACKQRMI,15)) ;11+2 pcs
170 S ACKQN=ACKQN+1 ;sub(31) L A retest
171 S ACKQA(ACKQN)="RTSTL^L^"_$G(^ACK(509850.9,ACKQRMI,35)) ;11+2 pcs
172 S ACKQN=ACKQN+1 ;sub(32) R B retest
173 S ACKQA(ACKQN)="RTSTRB^R^"_$G(^ACK(509850.9,ACKQRMI,72)) ;9+2 pcs
174 S ACKQN=ACKQN+1 ;sub(33) L B retest
175 S ACKQA(ACKQN)="RTSTLB^L^"_$G(^ACK(509850.9,ACKQRMI,82)) ;9+2 pcs
176 S ACKQN=ACKQN+1 ;sub(34) R AI & word node
177 S ACKQA(ACKQN)="RAI^R^"_$G(^ACK(509850.9,ACKQRMI,120)) ;23+2 pcs
178 S ACKQN=ACKQN+1 ;sub(35) L AI & word node
179 S ACKQA(ACKQN)="LAI^L^"_$G(^ACK(509850.9,ACKQRMI,121)) ;23+2 pcs
180 D COMMTS
181 Q
182WRTERR ;
183 I $L($G(ACKQE)) D
184 .S $P(ACKQA(1),U,5)=ACKQE
185 Q
186COMMTS ;add comments to transmit
187 ;INPUT ACKQRMI,ACKQN
188 Q:'$D(^ACK(509850.9,ACKQRMI,122)) Q:'$O(^ACK(509850.9,ACKQRMI,122,0))
189 N C,X S C=0
190C1 S C=$O(^ACK(509850.9,ACKQRMI,122,C)) Q:'C D
191 .S ACKQN=ACKQN+1,X=$G(^ACK(509850.9,ACKQRMI,122,C,0))
192 .S X=$TR(X,"^","")
193 .S ACKQA(ACKQN)="COM^"_C_U_X
194 G C1
Note: See TracBrowser for help on using the repository browser.