source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQASU2.m@ 629

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1ACKQASU2 ;HCIOFO/BH-NEW/EDIT VISIT QUASAR UTILITIES ; 04/01/99
2 ;;3.0;QUASAR;**1**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5 ;
6ADD S ACKCNT=ACKCNT+1 Q
7 ;
8 ;
9 ;
10POST(ACKVIEN) ;
11 K DIRUT,DTOUT
12 ;
13 N ACKEXPT,ACKK1,ACKK2,ACKARR,ACK,ACKSC,VAEL,ACKVSC,ACKVAO,ACKVRAD,ACKVENV
14 ;
15 ; Clear away Update PCE Problem list and Diag provider if invalid
16 N ACKPROB,ACKDD,ACKDREC,ACKDUP,ACKDPROV,ACKDIAG
17 S ACKDIAG=0
18 S ACKPROB=$$PROB^ACKQUTL4(ACKPCE,ACKDIV)
19 F S ACKDIAG=$O(^ACK(509850.6,ACKVIEN,1,ACKDIAG)) Q:'ACKDIAG D
20 . S ACKDREC=$G(^ACK(509850.6,ACKVIEN,1,ACKDIAG,0)) Q:'ACKDREC
21 . S ACKDUP=$P(ACKDREC,"^",3)
22 . S ACKDPROV=$P(ACKDREC,"^",4)
23 . I 'ACKPROB D Q
24 . . I ACKDUP'=""!(ACKDPROV'="") D
25 . . . K ACKDD
26 . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
27 . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
28 . . . D FILE^DIE("","ACKDD","") K ACKDD
29 . I ACKPROB D Q
30 . . I 'ACKDUP,ACKDPROV'="" D
31 . . . K ACKDD
32 . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
33 . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
34 . . . D FILE^DIE("","ACKDD","") K ACKDD
35 ;
36 ;------------------------------------------------
37 D ELIG^VADPT S ACKSC=$P(VAEL(3),U,1) K VAEL
38 ;
39GETDATA D GETS^DIQ(509850.6,ACKVIEN,"20;25;30;35","I","ACK")
40 ;
41 S ACKVSC=ACK(509850.6,ACKVIEN_",",20,"I")
42 S ACKVAO=ACK(509850.6,ACKVIEN_",",25,"I")
43 S ACKVRAD=ACK(509850.6,ACKVIEN_",",30,"I")
44 S ACKVENV=ACK(509850.6,ACKVIEN_",",35,"I")
45 ;
46 K ACK
47 ;
48NULL ; NUll out fields that should not bo present or have been set
49 ; incorrectly
50 ;
51 I ACKSC=0,ACKVSC'="" S ACK(509850.6,ACKVIEN_",",20)="" S ACKVSC=""
52 ;
53 I ACKAO=0,ACKVAO'="" S ACK(509850.6,ACKVIEN_",",25)=""
54 I ACKRAD=0,ACKVRAD'="" S ACK(509850.6,ACKVIEN_",",30)=""
55 I ACKENV=0,ACKVENV'="" S ACK(509850.6,ACKVIEN_",",35)=""
56 ;
57 I ACKSC=1,ACKVSC=1,ACKVAO'="" S ACK(509850.6,ACKVIEN_",",25)=""
58 I ACKSC=1,ACKVSC=1,ACKVRAD'="" S ACK(509850.6,ACKVIEN_",",30)=""
59 I ACKSC=1,ACKVSC=1,ACKVENV'="" S ACK(509850.6,ACKVIEN_",",35)=""
60 I $D(ACK) D FILE^DIE("","ACK") K ACK
61 ;
62 D CHKVST^ACKQUTL8(ACKVIEN,.ACKARR,1)
63 ;
64 I ACKARR=0 D MINIMUM G EXIT ; Minimum data not entered
65 ;
66 I ACKARR=-1 D CORRUPT,DELETE S ACKOUT=2 ; Corrupt
67 ;
68 I ACKARR=3 S ACKOUT=1 G EXIT ; Everything is okay
69 ;
70 I 'ACKPCE,ACKARR=2 S ACKOUT=1 G EXIT ; Interface off and no Quasar
71 ; ; errors - Everything is okay
72 ;
73 I ACKPCE D
74 . D PCE
75 . S ACKK1="" F S ACKK1=$O(ACKARR(1,ACKK1)) Q:ACKK1="" D
76 . . W !," ",ACKARR(1,ACKK1)
77 . S ACKK2="" F S ACKK2=$O(ACKARR(2,ACKK2)) Q:ACKK2="" D
78 . . W !," ",ACKARR(2,ACKK2)
79 . S ACKEXPT=$$EXPT(ACKVIEN)
80 . W !! D CHOICE1 W !!
81 ;
82 I 'ACKPCE D
83 . D QUASAR
84 . S ACKK1="" F S ACKK1=$O(ACKARR(1,ACKK1)) Q:ACKK1="" D
85 . . W !," ",ACKARR(1,ACKK1)
86 . W !! D CHOICE W !!
87 ;
88EXIT ; One way out
89 Q ACKOUT
90 ;
91 ;
92MINIMUM ; Minimum Data not entered. If New Visit user can either delete or
93 ; re-edit the visit if user is editing a visit user only has option
94 ; to re-edit the visit.
95 ;
96 D DISPLAY
97 I ACKVISIT="NEW" D Q
98 . K DIR
99 . S DIR("A")="Enter RETURN to Re-Edit Visit or '^' to Quit and Delete"
100 . S DIR(0)="E" D ^DIR K DIR
101 . I $D(DTOUT)!$D(DIRUT) S X="^" ; Time out or Quit
102 . I X="^" S ACKOUT=2 D DELETE Q
103 . S ACKOUT=0 Q ; Entered <Return>
104 ;
105 I ACKVISIT="EDIT" D Q
106 . K DIR
107 . S DIR("?")="This option will not Quit until Quasars Minimum Data Requirements have been entered"
108 . S DIR("A")="Press RETURN to Re-edit Visit",DIR(0)="E"
109 . D ^DIR
110 . S ACKOUT=0 Q
111 ;
112 ;
113DELETE ; Delete the entry
114 ;
115 W !!,$C(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
116 S DIK="^ACK(509850.6,",DA=ACKVIEN D ^DIK
117 Q
118 ;
119 ;
120CORRUPT ; Display corrupt data message
121 ;
122 W !!,"ERROR - This record has become corrupted.",!
123 ;
124 Q
125 ;
126QUASAR ; Display Quasar heading and missing fields
127 ;
128 W !!," WARNING - ",!
129 W " The following are fields required by QUASAR that have not been entered.",!
130 W " Enter <RETURN> to re-enter this function or '^' to quit.",!!
131 ;
132 Q
133 ;
134PCE ; Display PCE missing fields
135 ;
136 W @IOF
137 W " WARNING - ",!!
138 W " The following are fields required by QUASAR & PCE that have not been entered.",!
139 Q
140 ;
141PCE1 W !," '^' Quit & File the A&SP visit but do not send incomplete A&SP"
142 W !," visit to PCE. Or,"
143 ;
144 Q
145 ;
146CHOICE ; Display choice - either enter '^' to quit entry or <Return> to
147 ; re-enter the template
148 ;
149 K DIR S DIR(0)="E" D ^DIR K DIR
150 I +Y=1 S ACKOUT=0
151 I +Y=0 S ACKOUT=1
152 S:$D(DIRUT) ACKOUT=1
153 K DIRUT,DTOUT
154 Q
155 ;
156CHOICE1 ; Prompt for PCE choice - An Exception may not be set when the PCE Inte-
157 ; -face is on so dont prompt user with 'Send to PCE' options if no
158 ; exception is present (i.e. ACKEXPT=0).
159 ;
160 ; If EXCEPTION '^' - Quit but not send to PCE
161 ; R - Re-enter the template
162 ; C - Continue send with errors
163 ; '^' - Returns 2 C - Returns 1 R - Returns 0
164 ;
165 ; If not EXCEPTION '^' - Quit
166 ; R - Re-enter the template
167 ; C - Continue file with errors
168 ; '^' & C - Returns 2 R - Returns 0
169 ;
170DISP I ACKEXPT D PCE1
171 S DIR("A")=" (C)ontinue or (R)enter "
172 S DIR("B")="R"
173 I ACKEXPT S DIR("?")=" Enter 'R' to Re-enter this function and amend data, 'C' to Continue and send incomplete A&SP visit data to PCE or '^' to exit without sending to PCE."
174 I ACKEXPT'=1 S DIR("?")=" Enter 'R' to Re-enter this function and amend data or 'C' to Continue and file incomplete"
175 I ACKEXPT S DIR(0)="S^R:Re-enter this function & amend data;C:Continue & send incomplete A&SP visit data to PCE;"
176 I ACKEXPT'=1 S DIR(0)="S^R:Re-enter this function & amend data;C:Continue & file incomplete;"
177 D ^DIR K DIR
178 S:$D(DTOUT) X=U
179 S:$D(DIRUT) ACKOUT=2
180 I ACKEXPT I X="c"!(X="C") S ACKOUT=1
181 I ACKEXPT'=1 I X="c"!(X="C") S ACKOUT=2
182 I X="r"!(X="R") S ACKOUT=0
183 I X="^" S ACKOUT=2
184 ;
185 Q
186 ;
187UTLAUD ;
188 N ACK,ACKRAV,ACKLAV,ACKI,ACKR1,ACKR2,ACKR3,ACKR4,ACKL1,ACKL2,ACKL3,ACKL4
189 N ACKAR
190 ; Sets previous vist audiometric data into file
191 ;
192 I $L($G(ACKLAMD))>7 D Q
193 . F ACKI=1:1:16 S $P(^ACK(509850.6,ACKVIEN,4),U,ACKI)=$P(ACKLAMD,U,ACKI+1)
194 ;
195 ;
196 ; Calculates the average of the scores and sets the results into
197 ; visit file
198 ;
199 D VALUES
200 ;
201 ; Cannot calculate average if a null value exists
202 I ACKR1=""!(ACKR2="")!(ACKR3="")!(ACKR4="") G LEFT
203 S ACKRAV=ACKR1+ACKR2+ACKR3+ACKR4/4+.5\1 S:ACKRAV<0 ACKRAV=0
204 S ACKAR(509850.6,ACKVIEN_",","4.06")=ACKRAV
205 ;
206LEFT ; Cannot calculate average if a null value exists
207 I ACKL1=""!(ACKL2="")!(ACKL3="")!(ACKL4="") Q
208 S ACKLAV=ACKL1+ACKL2+ACKL3+ACKL4/4+.5\1 S:ACKLAV<0 ACKLAV=0
209 S ACKAR(509850.6,ACKVIEN_",","4.12")=ACKLAV
210 D FILE^DIE("K","ACKAR") K ACKAR
211 ;
212 Q
213 ;
214VALUES ; Get value for calculation
215 K ACK
216 D GETS^DIQ(509850.6,ACKVIEN,"4.02;4.03;4.04;4.05;4.08;4.09;4.1;4.11","I","ACK")
217 ;
218 S ACKR1=ACK(509850.6,ACKVIEN_",",4.02,"I")
219 S ACKR2=ACK(509850.6,ACKVIEN_",",4.03,"I")
220 S ACKR3=ACK(509850.6,ACKVIEN_",",4.04,"I")
221 S ACKR4=ACK(509850.6,ACKVIEN_",",4.05,"I")
222 ;
223 S ACKL1=ACK(509850.6,ACKVIEN_",",4.08,"I")
224 S ACKL2=ACK(509850.6,ACKVIEN_",",4.09,"I")
225 S ACKL3=ACK(509850.6,ACKVIEN_",",4.1,"I")
226 S ACKL4=ACK(509850.6,ACKVIEN_",",4.11,"I")
227 ;
228 K ACK
229 Q
230 ;
231EXPT(ACKVIEN) ; Passes back 1 or zero depending if visit has an Exception
232 ; entry set up.
233 N ACKEX
234 S ACKEX=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I") I ACKEX="" Q 0
235 I '$D(^ACK(509850.6,"AEX",ACKEX,ACKVIEN)) Q 0
236 Q 1
237 ;
238 ;
239DISPLAY ;
240 W !!,"The following field(s) are required by QUASAR but have not been entered.",!!
241 I $$GET1^DIQ(509850.6,ACKVIEN_",",5)="" W " CDR Account",!
242 I $$GET1^DIQ(509850.6,ACKVIEN_",",55)="" W " Appointment Time",!
243 W !!
244 Q
245 ;
Note: See TracBrowser for help on using the repository browser.