source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQAG08.m@ 1789

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1ACKQAG08 ;DDC/PJU;UPDATE AUDIOMETRIC EXAM FILE; [10/06/2005 ]
2 ;;3.0;QUASAR AUDIOMETRIC MODULE;**12**;11/01/02;
3 ;Loop through entries in 509850.9 and convert 'No Response' tags to
4 ;'+' added to value in initial or final fields. Retest field
5 ;was added with patch 12, so no tags that need conversion.
6 N IEN,P,N,CTR S (CTR,IEN)=0 ;W !!,"START:",$$HTE^XLFDT($H)
7L1 S IEN=$O(^ACK(509850.9,IEN)) G:'IEN PART2 ;S CTR=CTR+1
8 I $D(^ACK(509850.9,IEN,11)) D ;initial R air
9 .F P=1:1:12 D
10 ..S N=$P(^ACK(509850.9,IEN,11),U,P) Q:'N
11 ..I (N=2)!(N=3) D ;no response or masked no response
12 ...I $P($G(^ACK(509850.9,IEN,10)),U,P)["+" D Q
13 ....S $P(^ACK(509850.9,IEN,11),U,P)=$S(N=2:"",N=3:1)
14 ...S $P(^ACK(509850.9,IEN,10),U,P)=$P($G(^ACK(509850.9,IEN,10)),U,P)_"+"
15 ...S $P(^ACK(509850.9,IEN,11),U,P)=$S(N=2:"",N=3:1)
16 I $D(^ACK(509850.9,IEN,21)) D
17 .F P=1:1:12 D ;final R air
18 ..S N=$P(^ACK(509850.9,IEN,21),U,P) Q:'N
19 ..I (N=2)!(N=3) D
20 ...I $P($G(^ACK(509850.9,IEN,20)),U,P)["+" D Q
21 ....S $P(^ACK(509850.9,IEN,21),U,P)=$S(N=2:"",N=3:1)
22 ...S $P(^ACK(509850.9,IEN,20),U,P)=$P($G(^ACK(509850.9,IEN,20)),U,P)_"+"
23 ...S $P(^ACK(509850.9,IEN,21),U,P)=$S(N=2:"",N=3:1)
24 I $D(^ACK(509850.9,IEN,31)) D
25 .F P=1:1:12 D ;Initial L air
26 ..S N=$P(^ACK(509850.9,IEN,31),U,P) Q:'N
27 ..I (N=2)!(N=3) D
28 ...I $P($G(^ACK(509850.9,IEN,30)),U,P)["+" D Q
29 ....S $P(^ACK(509850.9,IEN,31),U,P)=$S(N=2:"",N=3:1)
30 ...S $P(^ACK(509850.9,IEN,30),U,P)=$P($G(^ACK(509850.9,IEN,30)),U,P)_"+"
31 ...S $P(^ACK(509850.9,IEN,31),U,P)=$S(N=2:"",N=3:1)
32 I $D(^ACK(509850.9,IEN,41)) D
33 .F P=1:1:12 D ;final L air
34 ..S N=$P($G(^ACK(509850.9,IEN,41)),U,P) Q:'N
35 ..I (N=2)!(N=3) D
36 ...I $P($G(^ACK(509850.9,IEN,40)),U,P)["+" D Q
37 ....S $P(^ACK(509850.9,IEN,41),U,P)=$S(N=2:"",N=3:1)
38 ...S $P(^ACK(509850.9,IEN,40),U,P)=$P($G(^ACK(509850.9,IEN,40)),U,P)_"+"
39 ...S $P(^ACK(509850.9,IEN,41),U,P)=$S(N=2:"",N=3:1)
40 I $D(^ACK(509850.9,IEN,71)) D
41 .F P=1:1:9 D ;Initial R bone
42 ..S N=$P(^ACK(509850.9,IEN,71),U,P) Q:'N
43 ..I (N=2)!(N=3) D
44 ...I $P($G(^ACK(509850.9,IEN,70)),U,P)["+" D Q
45 ....S $P(^ACK(509850.9,IEN,71),U,P)=$S(N=2:"",N=3:1)
46 ...S $P(^ACK(509850.9,IEN,70),U,P)=$P($G(^ACK(509850.9,IEN,70)),U,P)_"+"
47 ...S $P(^ACK(509850.9,IEN,71),U,P)=$S(N=2:"",N=3:1)
48 I $D(^ACK(509850.9,IEN,76)) D
49 .F P=1:1:9 D ;Final R bone
50 ..S N=$P(^ACK(509850.9,IEN,76),U,P) Q:'N
51 ..I (N=2)!(N=3) D
52 ...I $P($G(^ACK(509850.9,IEN,75)),U,P)["+" D Q
53 ....S $P(^ACK(509850.9,IEN,76),U,P)=$S(N=2:"",N=3:1)
54 ...S $P(^ACK(509850.9,IEN,75),U,P)=$P($G(^ACK(509850.9,IEN,75)),U,P)_"+"
55 ...S $P(^ACK(509850.9,IEN,76),U,P)=$S(N=2:"",N=3:1)
56 I $D(^ACK(509850.9,IEN,81)) D
57 .F P=1:1:9 D ;Initial L bone
58 ..S N=$P(^ACK(509850.9,IEN,81),U,P) Q:'N
59 ..I (N=2)!(N=3) D
60 ...I $P($G(^ACK(509850.9,IEN,80)),U,P)["+" D Q
61 ....S $P(^ACK(509850.9,IEN,81),U,P)=$S(N=2:"",N=3:1)
62 ...S $P(^ACK(509850.9,IEN,80),U,P)=$P($G(^ACK(509850.9,IEN,80)),U,P)_"+"
63 ...S $P(^ACK(509850.9,IEN,81),U,P)=$S(N=2:"",N=3:1)
64 I $D(^ACK(509850.9,IEN,86)) D
65 .F P=1:1:9 D ;Final l bone
66 ..S N=$P(^ACK(509850.9,IEN,86),U,P) Q:'N
67 ..I (N=2)!(N=3) D
68 ...I $P($G(^ACK(509850.9,IEN,85)),U,P)["+" D Q
69 ....S $P(^ACK(509850.9,IEN,86),U,P)=$S(N=2:"",N=3:1)
70 ...S $P(^ACK(509850.9,IEN,85),U,P)=$P($G(^ACK(509850.9,IEN,85)),U,P)_"+"
71 ...S $P(^ACK(509850.9,IEN,86),U,P)=$S(N=2:"",N=3:1)
72 G L1
73PART2 ;evaluate and move initial readings(masked) to final when needed
74 ;W !!,"START PART2 :",$$HTE^XLFDT($H)
75 N V1,T1,L1,V2,T2,L2 ;initial and final value, tag & mask level nodes
76 N NV1,NL1,NT1,NV2,NL2,NT2 ;NODES FOR CHANGES IF NEEDED
77 S IEN=0
78L2 S IEN=$O(^ACK(509850.9,IEN)) G:'IEN END
79 G:'$D(^ACK(509850.9,IEN,0)) L2 ;INVALID ENTRY
80AIRR ;Right Air
81 S NV1="^ACK(509850.9,"_IEN_",10)"
82 S NT1="^ACK(509850.9,"_IEN_",11)"
83 S NL1="^ACK(509850.9,"_IEN_",50)"
84 S NV2="^ACK(509850.9,"_IEN_",20)"
85 S NT2="^ACK(509850.9,"_IEN_",21)"
86 S NL2="^ACK(509850.9,"_IEN_",51)"
87 F P=1:1:12 D ;
88 .S V1=$P($G(^ACK(509850.9,IEN,10)),U,P)
89 .S T1=$P($G(^ACK(509850.9,IEN,11)),U,P)
90 .S L1=$P($G(^ACK(509850.9,IEN,50)),U,P)
91 .S V2=$P($G(^ACK(509850.9,IEN,20)),U,P)
92 .S T2=$P($G(^ACK(509850.9,IEN,21)),U,P)
93 .S L2=$P($G(^ACK(509850.9,IEN,51)),U,P)
94 .I (T1'="")!(T2'="")!(L1'="") D RULES()
95AIRL ;Left Air
96 S NV1="^ACK(509850.9,"_IEN_",30)"
97 S NT1="^ACK(509850.9,"_IEN_",31)"
98 S NL1="^ACK(509850.9,"_IEN_",60)"
99 S NV2="^ACK(509850.9,"_IEN_",40)"
100 S NT2="^ACK(509850.9,"_IEN_",41)"
101 S NL2="^ACK(509850.9,"_IEN_",61)"
102 F P=1:1:12 D ;
103 .S V1=$P($G(^ACK(509850.9,IEN,30)),U,P)
104 .S T1=$P($G(^ACK(509850.9,IEN,31)),U,P)
105 .S L1=$P($G(^ACK(509850.9,IEN,60)),U,P)
106 .S V2=$P($G(^ACK(509850.9,IEN,40)),U,P)
107 .S T2=$P($G(^ACK(509850.9,IEN,41)),U,P)
108 .S L2=$P($G(^ACK(509850.9,IEN,61)),U,P)
109 .I (T1'="")!(T2'="")!(L1'="") D RULES() ;apply rules
110RBONE ;Right Bone
111 S NV1="^ACK(509850.9,"_IEN_",70)"
112 S NT1="^ACK(509850.9,"_IEN_",71)"
113 S NL1="^ACK(509850.9,"_IEN_",90)"
114 S NV2="^ACK(509850.9,"_IEN_",75)"
115 S NT2="^ACK(509850.9,"_IEN_",76)"
116 S NL2="^ACK(509850.9,"_IEN_",91)"
117 F P=1:1:9 D
118 .S V1=$P($G(^ACK(509850.9,IEN,70)),U,P)
119 .S T1=$P($G(^ACK(509850.9,IEN,71)),U,P)
120 .S L1=$P($G(^ACK(509850.9,IEN,90)),U,P)
121 .S V2=$P($G(^ACK(509850.9,IEN,75)),U,P)
122 .S T2=$P($G(^ACK(509850.9,IEN,76)),U,P)
123 .S L2=$P($G(^ACK(509850.9,IEN,91)),U,P)
124 .I (T1'="")!(T2'="")!(L1'="") D RULES() ;apply rules
125LBONE ;Left Bone
126 S NV1="^ACK(509850.9,"_IEN_",80)"
127 S NT1="^ACK(509850.9,"_IEN_",81)"
128 S NL1="^ACK(509850.9,"_IEN_",100)"
129 S NV2="^ACK(509850.9,"_IEN_",85)"
130 S NT2="^ACK(509850.9,"_IEN_",86)"
131 S NL2="^ACK(509850.9,"_IEN_",101)"
132 F P=1:1:9 D
133 .S V1=$P($G(^ACK(509850.9,IEN,80)),U,P)
134 .S T1=$P($G(^ACK(509850.9,IEN,81)),U,P)
135 .S L1=$P($G(^ACK(509850.9,IEN,100)),U,P)
136 .S V2=$P($G(^ACK(509850.9,IEN,85)),U,P)
137 .S T2=$P($G(^ACK(509850.9,IEN,86)),U,P)
138 .S L2=$P($G(^ACK(509850.9,IEN,101)),U,P)
139 .I (T1'="")!(T2'="")!(L1'="") D RULES() ;apply rules
140 G L2
141END ;W !!,"STOP:",$$HTE^XLFDT($H),?60,"RECORDS:",CTR
142 S DIK="^ACK(509850.9,",DIK(1)=".02^DFN2" D ENALL^DIK K DIK
143 Q
144 ;
145RULES() ;Adjust Masking level, tag and value for *3*12 if needed
146 ;no CNT,DNT,CNM etc in 3*3 records but may have "+" from part1
147 ;L2 could be CNM if a re-run,V1 could be CNT or DNT if a re-run
148 ;1.final has val and (ML or mask tag) then will only use final on graph and just val for init
149 N MS1,MS2 S (MS1,MS2)=""
150 I L2!T2 S MS2=1 ;final masked
151 I L1'=""!T1 S MS1=1 ;initial masked
152 I V2'="",MS2 D Q ;has final masked value
153 .S $P(@(NT1),U,P)="" ;elim init tag
154 .S $P(@(NT2),U,P)="" ;elim final tag
155 .S $P(@(NL1),U,P)="" ;elim init ML
156 .I T2,L2="",V2'["*" S $P(@(NV2),U,P)=V2_"*" ;adjust if just had tag
157 ;2.fin missing Val or just + or ML and init has both then replace fin
158 I (('MS2)!("+"[V2)),("+"'[V1),MS1 D Q
159 .I T1,L1="",V1'["*" S V1=V1_"*" ;adjust if just had tag
160 .S $P(@(NV2),U,P)=V1 ;replace final val with initial val
161 .S $P(@(NL2),U,P)=L1 ;replace final ML with initial ML
162 .S $P(@(NT2),U,P)="" ;elim final tag
163 .S $P(@(NV1),U,P)="" ;elim init val
164 .S $P(@(NL1),U,P)="" ;elim init ML
165 .S $P(@(NT1),U,P)="" ;elim init tag
166 E I (T1'="")!(T2'="")!(L1'="") D ;eliminate 0's & invalid field values
167 .S $P(@(NT1),U,P)="" ;elim init tag
168 .S $P(@(NT2),U,P)="" ;elim final tag
169 .S $P(@(NL1),U,P)="" ;elim init ML
170 Q
Note: See TracBrowser for help on using the repository browser.