1 | ACKQUTL6 ;HCIOFO/BH-A&SP Utilities routine ; 5/6/03 11:07am
|
---|
2 | ;;3.0;QUASAR;**1,7**;Feb 11, 2000
|
---|
3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
---|
4 | ;
|
---|
5 | DATACHEK(X,ACKVIEN) ; Checks that the input (X) is a valid time also checks that
|
---|
6 | ; current user has supervisor status
|
---|
7 | ;
|
---|
8 | I $$TIMECHEK^ACKQASU5(ACKVIEN,"") Q 0
|
---|
9 | S X=$$TTIME(X) Q X
|
---|
10 | ;
|
---|
11 | ;
|
---|
12 | SUPER(DUZ) ; Function passes back true if DUZ belongs to a supervisor
|
---|
13 | N ACKDUZ
|
---|
14 | S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ)
|
---|
15 | I 'ACKDUZ Q 0
|
---|
16 | I $D(^ACK(509850.3,ACKDUZ,0)),$P(^(0),"^",6)=1 Q 1
|
---|
17 | Q 0
|
---|
18 | ;
|
---|
19 | ;
|
---|
20 | TTIME(X) ; Time input validation used within input transform of
|
---|
21 | ; the Appointment time field (#55) of the visit file.
|
---|
22 | ;
|
---|
23 | ; X=Time entered by the user
|
---|
24 | ; Return value either O if input was invalid or formatted
|
---|
25 | ; time.
|
---|
26 | ;
|
---|
27 | N Y,ACKFMT,ACKAMPM
|
---|
28 | I X="NOW"!(X="now") D NOW^%DTC S X=$P(%,".",2)
|
---|
29 | I X="NOO" S X="NOON"
|
---|
30 | ;
|
---|
31 | S %DT="%DTS"
|
---|
32 | ; S DIR(0)="D^::%DT"
|
---|
33 | S X="2990303@"_X
|
---|
34 | K Y
|
---|
35 | D ^%DT
|
---|
36 | ;
|
---|
37 | I Y="-1" Q 0
|
---|
38 | S Y=$P(Y,".",2)
|
---|
39 | S ACKT="."_Y
|
---|
40 | ;
|
---|
41 | S ACKFMT=Y
|
---|
42 | ;. D AMPM
|
---|
43 | ;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_":"_$E(ACKFMT,5,6)_ACKAMPM_")"
|
---|
44 | ;. D AMPM
|
---|
45 | ;. W ?30,"("_+$E(ACKFMT,1,2)_":"_$E(ACKFMT,3,4)_ACKAMPM_")"
|
---|
46 | W ?30,"("_$$FMT(ACKFMT)_")"
|
---|
47 | Q ACKT
|
---|
48 | ;
|
---|
49 | FMT(ACKFMT,ACKSTYL) ; convert Quasar Time to external format
|
---|
50 | ; inputs:- ACKFMT - fileman time (internal) (reqd)
|
---|
51 | ; can be passed in as 'date.time','.time' or just 'time'
|
---|
52 | ; ACKSTYL - style of output (optional)
|
---|
53 | ; where 0 = 12:mm[:ss] am/pm (no lead space)
|
---|
54 | ; 1 = 12:mm[:ss] am/pm (lead space)
|
---|
55 | ; 2 = 12:mm am/pm
|
---|
56 | N ACKHH,ACKAMPM
|
---|
57 | S ACKSTYL=+$G(ACKSTYL)
|
---|
58 | I ACKFMT["." S ACKFMT=$P(ACKFMT,".",2)
|
---|
59 | S ACKFMT=ACKFMT_"00000"
|
---|
60 | S ACKHH=+$E(ACKFMT,1,2)
|
---|
61 | G:ACKSTYL=1 FMT1
|
---|
62 | G:ACKSTYL=2 FMT2
|
---|
63 | FMT0 ; style 0 - 12:mm[:ss] am/pm (the default)
|
---|
64 | S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
|
---|
65 | I ACKHH<1 S ACKHH=12
|
---|
66 | I ACKHH>12 S ACKHH=ACKHH-12
|
---|
67 | S ACKFMT=ACKHH_":"_$E(ACKFMT,3,4)_$S(+$E(ACKFMT,5,6)>0:":"_$E(ACKFMT,5,6),1:"")_ACKAMPM
|
---|
68 | Q ACKFMT
|
---|
69 | FMT1 ; style 1 - 12:mm[:ss] am/pm (with lead space if hour<10)
|
---|
70 | S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
|
---|
71 | I ACKHH<1 S ACKHH=12
|
---|
72 | I ACKHH>12 S ACKHH=ACKHH-12
|
---|
73 | S ACKFMT=$J(ACKHH,2)_":"_$E(ACKFMT,3,4)_$S(+$E(ACKFMT,5,6)>0:":"_$E(ACKFMT,5,6),1:"")_ACKAMPM
|
---|
74 | Q ACKFMT
|
---|
75 | FMT2 ; style 2 - 12:mm am/pm
|
---|
76 | S ACKAMPM=" AM" I ACKHH>11,ACKHH<24 S ACKAMPM=" PM"
|
---|
77 | I ACKHH<1 S ACKHH=12
|
---|
78 | I ACKHH>12 S ACKHH=ACKHH-12
|
---|
79 | S ACKFMT=$J(ACKHH,2)_":"_$E(ACKFMT,3,4)_ACKAMPM
|
---|
80 | Q ACKFMT
|
---|
81 | ;
|
---|
82 | DUPECHK(X,DA,ACKP) ; Check there are no previous duplicate entries
|
---|
83 | N ACKTGT,ACKCLIN,ACKVD,ACKPAT
|
---|
84 | S ACKPAT=ACKP
|
---|
85 | D GETS^DIQ(509850.6,DA_",",".01;1;2.6","I","ACKTGT")
|
---|
86 | S ACKVD=$G(ACKTGT(509850.6,DA_",",.01,"I")) I ACKVD="" Q 1
|
---|
87 | I ACKPAT="" S ACKPAT=$G(ACKTGT(509850.6,DA_",",1,"I")) I ACKPAT="" Q 1
|
---|
88 | S ACKCLIN=$G(ACKTGT(509850.6,DA_",",2.6,"I")) I ACKCLIN="" Q 1
|
---|
89 | I $D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,X)) Q 0
|
---|
90 | Q 1
|
---|
91 | ;
|
---|
92 | DUPCHK ; Called from xecutable help of Appointment Time field when ACKITME is
|
---|
93 | ; defined. This will only be defined if DUPECHK returned false
|
---|
94 | W !!,"Quasar already has a Visit entry for this Patient, within the same Clinic,"
|
---|
95 | W !,"on the same date at the same time."
|
---|
96 | W !!,"Please re-enter a new Appointment Time.",!!
|
---|
97 | K ACKITME Q
|
---|
98 | ;
|
---|
99 | ;
|
---|
100 | CDR() ; COMPUTE SUGGESTED CDR BASED ON TREATING SPECIALTY
|
---|
101 | S VAIP("D")=ACKVD D IN5^VADPT S ACKTS=+$$GET1^DIQ(45.7,+VAIP(8),1,"I"),ACKCDN=$$GET1^DIQ(42.4,ACKTS,6)_".00"
|
---|
102 | S ACKCDP=$S($O(^ACK(509850,"B",ACKCDN,0)):$O(^(0)),1:0) I 'ACKCDP S ACKCDP=$O(^ACK(509850,"B","2611.00",0))
|
---|
103 | S ACKCDN=$P(^ACK(509850,ACKCDP,0),U),ACKCD=$P(^(0),U,2)
|
---|
104 | K %,%H,%I,ACKTS,ACKCDP,VAIP,VAERR
|
---|
105 | W !!,"Suggested CDR Account :",ACKCDN," ",ACKCD,!
|
---|
106 | Q ACKCDN
|
---|
107 | ;
|
---|
108 | ;----------------------------------------------------------------
|
---|
109 | ; Routines and Utilities used within the Clinician Template
|
---|
110 | ;
|
---|
111 | ;
|
---|
112 | STAFFNO(X) ; Finds valid staff No. to be used when allocating next time
|
---|
113 | ;
|
---|
114 | N ACKFIRST,ACKFIND,ACKX
|
---|
115 | S ACKFIRST=1
|
---|
116 | I X=9999 S X="0000" S ACKFIRST=0
|
---|
117 | D GETNEXT,FILE
|
---|
118 | Q
|
---|
119 | ;
|
---|
120 | GETNEXT ;
|
---|
121 | S ACKFIND=0
|
---|
122 | F Q:ACKFIND D
|
---|
123 | . S ACKX=+X
|
---|
124 | . S X=X+1
|
---|
125 | . I X=9999,ACKFIRST S ACKFIRST=0 S X=0 Q
|
---|
126 | . I X=9999,'ACKFIRST S ACKFIND=1 Q
|
---|
127 | . S X=$E("0000",$L(X)+1,4)_X
|
---|
128 | . I '$D(^ACK(509850.3,"C",X)) S ACKFIND=1,X=ACKX Q
|
---|
129 | Q
|
---|
130 | ;
|
---|
131 | FILE ;
|
---|
132 | S ^ACK(509850.3,"ALID")=$E("0000",$L(X)+1,4)_X
|
---|
133 | Q
|
---|
134 | ;
|
---|
135 | ;
|
---|
136 | IDATE(D0,Y) ; Checks that the entered Inactive date falls after the
|
---|
137 | ; Active date (if one has been entered).
|
---|
138 | I Y="" Q 1 ; Its valid to not enter an inactivation date.
|
---|
139 | N ACKACT
|
---|
140 | S ACKACT=$$GET1^DIQ(509850.3,D0,.03,"I") I ACKACT="" Q 1
|
---|
141 | I Y<ACKACT Q 0
|
---|
142 | Q 1
|
---|
143 | ;
|
---|
144 | ADATE(D0,Y) ; Checks that the entered Active date falls before the
|
---|
145 | ; Inactive date (if one has been entered).
|
---|
146 | N ACKINA
|
---|
147 | S ACKINA=$$GET1^DIQ(509850.3,D0,.04,"I") I ACKINA="" Q 1
|
---|
148 | I Y>ACKINA Q 0
|
---|
149 | Q 1
|
---|
150 | ;
|
---|
151 | STAFFREF(X,DA) ; Cross Reference called from Cross Reference 'Logic'
|
---|
152 | ; of .01 field of Staff file.
|
---|
153 | N ACKNAME
|
---|
154 | S ACKNAME=$$GET1^DIQ(8930.3,X_",",.01)
|
---|
155 | S ^ACK(509850.3,"D",ACKNAME,DA)=""
|
---|
156 | Q
|
---|
157 | ;
|
---|
158 | REINDEX() ; Re-Indexes 'D' Cross Reference of Staff file
|
---|
159 | ; First checks that all ^USR(8930.3 entries that 509850.3 points to
|
---|
160 | ; still exist
|
---|
161 | N ACK01,ACK,ACKARR,ACKCNT
|
---|
162 | K ACKARR
|
---|
163 | S ACK=0,ACKCNT=0
|
---|
164 | F S ACK=$O(^ACK(509850.3,ACK)) Q:'ACK D
|
---|
165 | . S ACK01=$P(^ACK(509850.3,ACK,0),"^",1)
|
---|
166 | . I '$D(^USR(8930.3,ACK01,0)) D SETARR(ACK)
|
---|
167 | ;
|
---|
168 | I $D(ACKARR) D Q 0
|
---|
169 | . W !!,"Warning - The following user(s) have been deleted from the USR Class Membership"
|
---|
170 | . W !,"file (#8930.3)."
|
---|
171 | . W !,"Quasar's A&SP Staff file (#509850.3) points to this file."
|
---|
172 | . W !,"The Quasar staff member(s) need to be re-entered into the USR Class Membership"
|
---|
173 | . W !,"file (8930.3) and the associated Quasar staff record amended to point to this"
|
---|
174 | . W !,"new entry.",!!
|
---|
175 | . N ACK1
|
---|
176 | . S ACK1=""
|
---|
177 | . F S ACK1=$O(ACKARR(ACK1)) Q:ACK1="" D
|
---|
178 | . . W " "_ACKARR(ACK1),!
|
---|
179 | . W !!
|
---|
180 | . W "Please inform IRM/National VistA Support of this problem. This error"
|
---|
181 | . W !,"can be re-created by running this option again."
|
---|
182 | . W !!
|
---|
183 | ;
|
---|
184 | N DA,D0,X,Y
|
---|
185 | K ^ACK(509850.3,"D")
|
---|
186 | S DIK="^ACK(509850.3,"
|
---|
187 | S DIK(1)=".01^D"
|
---|
188 | D ENALL^DIK
|
---|
189 | Q 1
|
---|
190 | ;
|
---|
191 | SETARR(ACK) ;
|
---|
192 | N ACKNAME
|
---|
193 | S ACKNAME=""
|
---|
194 | F S ACKNAME=$O(^ACK(509850.3,"D",ACKNAME)) Q:ACKNAME="" D
|
---|
195 | . I $D(^ACK(509850.3,"D",ACKNAME,ACK)) S ACKCNT=ACKCNT+1 S ACKARR(ACKCNT)=ACKNAME
|
---|
196 | Q
|
---|
197 | ;
|
---|
198 | LONG(ACKPC,ACKQPR) ; Displays Long Description of Procedure Code
|
---|
199 | ;
|
---|
200 | Q
|
---|
201 | N ACKQ,ACKRES,ACKNEW,ACKSTR,ACK1,ACKQARR,ACKLEN,ACKCNT S ACKSTR="",ACKCNT=0
|
---|
202 | S ACK1=0
|
---|
203 | F S ACK1=$O(^ICPT(ACKPC,"D",ACK1)) Q:'ACK1 D
|
---|
204 | . S ACKNEW=^ICPT(ACKPC,"D",ACK1,0)
|
---|
205 | . S ACKNEW=$$STRIP(ACKNEW)
|
---|
206 | . I $G(ACKSTR)'="" S ACKNEW=ACKSTR_" "_ACKNEW
|
---|
207 | . S ACKLEN=$L(ACKNEW)
|
---|
208 | . I ACKLEN>54 D
|
---|
209 | . . I ACKLEN=55 S ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW S ACKSTR="" Q
|
---|
210 | . . S ACKRES=$$FORMAT(ACKNEW) S ACKNEW=$P(ACKRES,"^",1),ACKSTR=$P(ACKRES,"^",2),ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW
|
---|
211 | . I ACKLEN<55 S ACKSTR=ACKNEW
|
---|
212 | I $G(ACKSTR)'="" D
|
---|
213 | . S ACKQ=1
|
---|
214 | . F Q:'ACKQ D
|
---|
215 | . . S ACKNEW=ACKSTR S ACKRES=$$FORMAT(ACKNEW)
|
---|
216 | . . S ACKNEW=$P(ACKRES,"^",1),ACKSTR=$P(ACKRES,"^",2)
|
---|
217 | . . S ACKCNT=ACKCNT+1,ACKQARR(ACKCNT)=ACKNEW
|
---|
218 | . . I $G(ACKSTR)="" S ACKQ=0
|
---|
219 | ;
|
---|
220 | ; Display Array
|
---|
221 | ;
|
---|
222 | I '$D(ACKQARR) Q
|
---|
223 | N ACKK1,ACKQUIT
|
---|
224 | S ACKK1="",ACKQUIT=0
|
---|
225 | W !!," Long Description: "
|
---|
226 | F S ACKK1=$O(ACKQARR(ACKK1)) Q:'ACKK1!(ACKQUIT) D
|
---|
227 | . I ACKK1'=1 W !," "
|
---|
228 | . W ACKQARR(ACKK1) I ACKQPR=1,ACKK1=3 W "..." S ACKQUIT=1
|
---|
229 | W !
|
---|
230 | ;
|
---|
231 | Q
|
---|
232 | ;
|
---|
233 | FORMAT(ACKNEW) ;
|
---|
234 | ;
|
---|
235 | N ACKRES,ACKCCT,ACKEND,ACKN
|
---|
236 | I $L(ACKNEW)<56 S ACKRES=ACKNEW_"^"_"" Q ACKRES
|
---|
237 | S ACKCCT=0,ACKEND=0
|
---|
238 | F Q:ACKEND D
|
---|
239 | . S ACKCCT=ACKCCT+1
|
---|
240 | . I $L($P(ACKNEW," ",1,ACKCCT))<56 S ACKN=ACKCCT
|
---|
241 | . I $L($P(ACKNEW," ",1,ACKCCT))'<56 S ACKEND=1
|
---|
242 | S ACKRES=$P(ACKNEW," ",1,ACKN)_"^"_$P(ACKNEW," ",ACKN+1,999)
|
---|
243 | Q ACKRES
|
---|
244 | ;
|
---|
245 | STRIP(ACKNEW) ;
|
---|
246 | N ACKARRAY,ACKCT,ACKLEN,ACKX,ACKY,ACKI
|
---|
247 | S ACKY="",ACKCT=0
|
---|
248 | S ACKLEN=$L(ACKNEW)
|
---|
249 | F ACKI=1:1:ACKLEN D
|
---|
250 | . S ACKX=$E(ACKNEW,ACKI,ACKI)
|
---|
251 | . I ACKX'=" " S ACKY=ACKY_ACKX
|
---|
252 | . I ACKX=" ",ACKY'="" S ACKCT=ACKCT+1 S ACKARRAY(ACKCT)=ACKY S ACKY=""
|
---|
253 | . I ACKI=ACKLEN,ACKY'="" S ACKCT=ACKCT+1 S ACKARRAY(ACKCT)=ACKY S ACKY=""
|
---|
254 | ;
|
---|
255 | N ACKLOOP,ACKSTRG
|
---|
256 | S ACKLOOP=0,ACKSTRG=""
|
---|
257 | F S ACKLOOP=$O(ACKARRAY(ACKLOOP)) Q:ACKLOOP="" D
|
---|
258 | . S ACKSTRG=ACKSTRG_ACKARRAY(ACKLOOP)_" "
|
---|
259 | ;
|
---|
260 | S ACKLEN=$L(ACKSTRG)
|
---|
261 | I $E(ACKSTRG,ACKLEN,ACKLEN)=" " S ACKSTRG=$E(ACKSTRG,1,ACKLEN-1)
|
---|
262 | ;
|
---|
263 | Q ACKSTRG
|
---|
264 | PLIST(ACKPAT,ACKDC) ; Determines if an entry exists in the Problem file
|
---|
265 | ; returns Status as first piece, Problem List IEN as second piece
|
---|
266 | ; (Status^IEN)
|
---|
267 | ; Status values - 1=Inactive, 2=Active
|
---|
268 | N ACKIFN,ACKPLQT
|
---|
269 | S (ACKIFN,ACKPLQT)=0
|
---|
270 | I $D(^AUPNPROB("AC",ACKPAT)) D
|
---|
271 | . F S ACKIFN=$O(^AUPNPROB("AC",ACKPAT,ACKIFN)) Q:(ACKIFN="") D Q:ACKPLQT
|
---|
272 | . .I $D(^AUPNPROB("B",ACKDC,ACKIFN)) S ACKPLQT=ACKIFN
|
---|
273 | I ACKPLQT Q $S($P($G(^AUPNPROB(ACKPLQT,0)),U,12)="A":2,1:1)_U_ACKPLQT
|
---|
274 | Q 0
|
---|
275 | ;
|
---|