source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQASU1.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1ACKQASU1 ;HCIOFO/BH-Quasar New Visit Utilities routine ; 04/01/99
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5CLIN(ACKDIV,ACKOPT) ; prompt for clinic
6 ; inputs: - ACKDIV - selected Division
7 ; ACKOPT - set to U to force uppercase entry
8 ; returns: 0 - if no valid clinics to select from
9 ; null - if no clinic selected
10 ; or X^Y^ where
11 ; X - ien of selected clinic
12 ; & Y - clinic name
13 ;
14 N ACKIEN,ACKDEF,ACKCLINN,ACKC,ACKCLIN,ACKDFLT
15 ;
16 ; get the clinics for the selected Division
17 D GETCLIN(ACKDIV,.CLINVARR,$G(ACKOPT))
18 ;
19 ; if no valid clinics then exit
20 I CLINVARR=0 S ACKCLIN=0 G CLINX
21 ;
22 ; only one clinic exists, select it then exit
23 I CLINVARR=1 D G CLINX
24 . S ACKCLIN=$P(CLINVARR(1,1),U,1,2)_U
25 ;
26 ; find users last clinic selection
27 S ACKDEF=$$FIND1^DIC(509850.831,","_ACKDIV_",1,",""," ")
28 S ACKDEF=$S(ACKDEF:$$EXTERNAL^DILFD(509850.831,".01","",ACKDEF),1:"")
29 ;
30 ; ensure users last selection is valid
31 S ACKDEF=$$UP("U",ACKDEF) ; convert to uppercase
32 I ACKDEF'="",'$D(CLINVARR(2,ACKDEF)) S ACKDEF=""
33 S ACKDFLT=$S(ACKDEF="":"",1:"2^"_ACKDEF) ; passed to input fnctn as default
34 ;
35 ; multiple clinics exist, only one required.
36 I CLINVARR>1 D G CLINX
37 . D SELECT^ACKQSEL(1,"CLINVARR(2)","CLINVARR(4)","CLINIC^35","D CLINHLP^ACKQASU1",ACKDFLT)
38 . ; get CLINIC IEN
39 . I $O(CLINVARR(4,""))="" S ACKCLIN="" Q ; quit or timed out
40 . S ACKCLINN=$O(CLINVARR(4,"")),ACKC=CLINVARR(2,ACKCLINN)
41 . S ACKIEN=$P(CLINVARR(1,ACKC),U,1)
42 . D RECALL^DILFD(509850.831,ACKIEN_","_ACKDIV_",1,",DUZ)
43 . S ACKCLIN=$P(CLINVARR(1,ACKC),U,1,2)_U
44 ;
45CLINX ; end
46 Q ACKCLIN
47 ;
48CLINHLP ; displays help text for the clinic prompt
49 N X,DIWL,DIWR,DIWF
50 S DIWL=1,DIWR=80,DIWF=""
51 ;
52 S X=" " D ^DIWP
53 S X=" Enter the name of a Clinic from the A&SP Site Parameters File." D ^DIWP
54 S X=" Enter '??' to see a list of the available Clinics, '^' to exit." D ^DIWP
55 D ^DIWW
56 Q
57 ;
58 ;
59GETCLIN(ACKDIV,CLINVARR,ACKOPT) ; get all the valid clinics and put them in CLINVARR
60 ;
61 ; INPUT: ACKDIV - the selected Division
62 ; CLINVARR - array used to return clinics (passed by reference)
63 ; ACKOPT - set to U for Uppercase entry only
64 ; RETURNS: CLINVARR= number found (n)
65 ; CLINVARR(1,n)=x^name
66 ; CLINVARR(2,name)=n
67 ; and CLINVARR(3,x)=n
68 ; where x=IEN of clinic from parameters file
69 ; and name=the clinic name
70 ;
71 N ACKTGT,ACKMSG,ACKSCRN,ACK,CLIN,CLINNAME
72 K CLINVARR
73 D LIST^DIC(509850.831,","_ACKDIV_",1,",".01","I","*","","","","","","ACKTGT","ACKMSG")
74 ; now transfer to output array
75 S CLINVARR=$P(ACKTGT("DILIST",0),U,1)
76 FOR ACK=1:1:CLINVARR D
77 . S CLIN=ACKTGT("DILIST",1,ACK)
78 . S CLINNAME=$$GET1^DIQ(44,CLIN,.01)
79 . S CLINVARR(1,ACK)=CLIN_U_CLINNAME
80 . S CLINVARR(2,$$UP($G(ACKOPT),CLINNAME))=ACK
81 . S CLINVARR(3,CLIN)=ACK
82 Q
83 ;
84UP(ACKOPT,X) ; Convert X to uppercase (if requested)
85 I ACKOPT["U" Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
86 Q X
87 ;
88DUPCHK(ACKPAT,ACKVD) ; Check for Duplicate Visit by this patient on this Date
89 ; this function will determine if the patient has another visit on
90 ; the selected date. If so the user may choose to select an
91 ; existing visit, or confirm that they are entering a new visit.
92 ; inputs: ACKPAT - patient DFN
93 ; ACKVD - visit date
94 ; returns: -1 if user quit or timed out
95 ; 0 create a new visit
96 ; (ie either no duplicates or user did not select
97 ; a duplicate)
98 ; >0 ien of selected visit
99 ;
100 N ACKVIEN,ACKTGT,ACKCP,ACKCLN,ACKVSC,ACKTIME,ACKCT,ACKVSEL,ACKSEL
101 N X,Y,%,DIR,ACKSEQ,ACKTIME,ACKVSEL
102 S ACKVSEL=0 ; return variable
103 ;
104 ; initialise temp file for data storage
105 K ^TMP("ACKQASU1",$J,"DUPCHK")
106 ;
107 ; get all visits for patient on given date, create array in time order
108 S ACKVIEN=0,ACKCT=0
109 F S ACKVIEN=$O(^ACK(509850.6,"APD",ACKPAT,ACKVD,ACKVIEN)) Q:'ACKVIEN D
110 . K ACKTGT S ACKCT=ACKCT+1
111 . D GETS^DIQ(509850.6,ACKVIEN_",","2.5;2.6;4;55","I","ACKTGT")
112 . S ACKCP=ACKTGT(509850.6,ACKVIEN_",",2.5,"I") ; is this C&P?
113 . S ACKCLN=ACKTGT(509850.6,ACKVIEN_",",2.6,"I") ; clinic
114 . S ACKVSC=ACKTGT(509850.6,ACKVIEN_",",4,"I") ; visit stop code
115 . S ACKTM=+ACKTGT(509850.6,ACKVIEN_",",55,"I") ; appointment time
116 . S ^TMP("ACKQASU1",$J,"DUPCHK",1,ACKTM,ACKVIEN)=""
117 . S ^TMP("ACKQASU1",$J,"DUPCHK",2,ACKVIEN)=ACKVD_U_ACKCP_U_ACKCLN_U_ACKVSC_U_ACKTM_U
118 ;
119 ; if no duplicate visits found then exit
120 I 'ACKCT S ACKVSEL=0 G DUPCHKX
121 ;
122 ; Display duplicates for this patient today
123 W !,$S(ACKCT=1:"One visit has ",1:ACKCT_" visits have ")_"already been entered for this date and patient.",!
124 ;
125 ; run down the visits in time order, allocate sequence number and display
126 S ACKTM="",ACKSEQ=0
127 F S ACKTM=$O(^TMP("ACKQASU1",$J,"DUPCHK",1,ACKTM)) Q:ACKTM="" D
128 . S ACKVIEN=""
129 . F S ACKVIEN=$O(^TMP("ACKQASU1",$J,"DUPCHK",1,ACKTM,ACKVIEN)) Q:ACKVIEN="" D
130 . . S ACKSEQ=ACKSEQ+1
131 . . S $P(^TMP("ACKQASU1",$J,"DUPCHK",3,ACKSEQ),U,1)=ACKVIEN
132 . . S TMP=^TMP("ACKQASU1",$J,"DUPCHK",2,ACKVIEN)
133 . . S ACKTIME=$$FMT^ACKQUTL6(ACKTM,1)
134 . . S ACKVD=$P(TMP,U,1)
135 . . S ACKCANDP=$S($P(TMP,U,2):"C&P EXAM",1:"")
136 . . S ACKCLN=$P(TMP,U,3),ACKCLNNM=$S(+ACKCLN=0:"",1:$$GET1^DIQ(44,ACKCLN_",",.01,"E")) ; clinic name
137 . . S ACKVSC=$P(TMP,U,4),ACKSTOP=$$ACKSTOP(ACKVSC) ; visit stop code
138 . . ; display visits
139 . . W !,$J(ACKSEQ,3),". ",$$DATE(ACKVD)
140 . . W ?20,ACKTIME,?32,$E(ACKCLNNM,1,30),?64,ACKSTOP,?70,ACKCANDP
141 ;
142ASK1 ; ask if one of the displayed visits is the one to be edited
143 W !!,"Is "_$S(ACKCT=1:"the appointment",1:"one of the appointments")
144 W " shown here the one you wish to edit"
145 S %=2 D YN^DICN
146 I %=-1,%Y?1"^"1.E W !,"Jumping not allowed." G ASK1
147 ;
148 ; if user does not want an existing visit then exit
149 I %=2 D S ACKVSEL=0 G DUPCHKX
150 . W !!,"Ok, adding another visit for this patient/date.",!!
151 ; if user quit or timed out then exit
152 I %="-1" S ACKVSEL=-1 G DUPCHKX
153 ; if any value other than YES, display help and re-prompt
154 I %'=1 S ACKQHLP=2 D ^ACKQHLP G ASK1
155 ;
156 ; if the user answered YES and there is only one visit then exit
157 I ACKCT=1 S ACKVSEL=$P(^TMP("ACKQASU1",$J,"DUPCHK",3,1),U,1) G DUPCHKX
158 ;
159SELECT ; prompt for which visit
160 S DIR(0)="N^1:"_ACKSEQ
161 S DIR("A")="Select by number"
162 S DIR("?")="Select the appointment you wish to edit from the above list"
163 D ^DIR K DIR
164 I $D(DIRUT) S ACKVSEL=-1 G DUPCHKX ; quit or timed out
165 S ACKSEL=+Y
166 ; get selected Visit ien
167 S ACKVSEL=$P(^TMP("ACKQASU1",$J,"DUPCHK",3,ACKSEL),U,1)
168 ;
169DUPCHKX ; exit point
170 K ^TMP("ACKQASU1",$J,"DUPCHK")
171 Q ACKVSEL
172 ;
173ACKSTOP(ACKVSC) ; translate visit stop code for display
174 I ACKVSC="A" Q "AUD"
175 I ACKVSC="S" Q "SPE"
176 I ACKVSC="AT" Q "TEL"
177 I ACKVSC="ST" Q "TEL"
178 Q ""
179 ;
180DATE(Y) ; convert date portion of Y to external format
181 S Y=Y\1 D DD^%DT
182 Q Y
183 ;
184 ;
185PCEVST1(ACKVD,ACKPAT,ACKCLIN) ; Checks to see if patients has a PCE visit for
186 ; selected clinic on visit date
187 ;
188 N ACKDATE,ACK,ACKPASS,ACKPIEN
189 S ACKPASS=0
190 S X1=ACKVD,X2="-1" D C^%DTC S X=X_".99"
191 F S X=$O(^AUPNVSIT("AET",ACKPAT,X)) Q:X=""!($P(X,".",1)>ACKVD)!(ACKPASS) D
192 . I $D(^AUPNVSIT("AET",ACKPAT,X,ACKCLIN)) S ACKPASS=1
193 Q ACKPASS
194 ;
195 ;
196EXCEPT ; Displays Error message explaining that the visit has previously been
197 ; sent to PCE and that the PCE interface is now off. The changes
198 ; made here in Quasar will therefore not be sent to PCE thus causing
199 ; a data disparity between the two systems.
200 W !!,"WARNING"
201 W !!,"This visit has Previously been sent to PCE."
202 W !,"The edited visit will not be sent to PCE because (within the Site Parameters)"
203 W !,"either the INTERFACE WITH PCE field is set to off, the SEND TO PCE field for"
204 W !,"this Division is set to off or this visits Visit Date is before the PCE"
205 W !,"INTERFACE START DATE."
206 W !!,"Data will now be different between the Quasar and the PCE visit."
207 W !,"Please take the appropriate corrective action.",!
208 W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" W ! D ^DIR
209 Q
Note: See TracBrowser for help on using the repository browser.