source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQUTL6.m@ 1046

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

initial load of WorldVistAEHR

File size: 8.6 KB
Line 
1ACKQUTL6 ;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 ;
5DATACHEK(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 ;
12SUPER(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 ;
20TTIME(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 ;
49FMT(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
63FMT0 ; 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
69FMT1 ; 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
75FMT2 ; 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 ;
82DUPECHK(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 ;
92DUPCHK ; 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 ;
100CDR() ; 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 ;
112STAFFNO(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 ;
120GETNEXT ;
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 ;
131FILE ;
132 S ^ACK(509850.3,"ALID")=$E("0000",$L(X)+1,4)_X
133 Q
134 ;
135 ;
136IDATE(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 ;
144ADATE(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 ;
151STAFFREF(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 ;
158REINDEX() ; 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 ;
191SETARR(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 ;
198LONG(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 ;
233FORMAT(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 ;
245STRIP(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
264PLIST(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 ;
Note: See TracBrowser for help on using the repository browser.