source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDVWMKPI.m@ 1726

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

initial load of WorldVistAEHR

File size: 9.3 KB
Line 
1SDVWMKPI ;ENHANCED MAKE AN APPOINTMENT SDAPI 11/18/06 ;2/22/07 17:08
2 ;;5.3;Scheduling;**502**;Aug 13, 1993 ;Build 14
3 ; Copyright (C) 2007 WorldVistA
4 ; GNU General Public License
5 ;
6EN(DFN,SD1,SC,STYP,SDARRAY) ;
7 ; MAKE AN APPOINTMENT
8 ; INPUT
9 ; DFN PATIENT(REQUIRED)
10 ; SD1 APPOINTMENT DATE (REQUIRED)
11 ; SC CLINIC FOR APPOINTMENT (REQUIRED)
12 ; STYP (REQUIRED)
13 ; =1 C&P
14 ; =2 10-10
15 ; =3 SCHEDULED APPOINTMENT
16 ; =4 UNSCHEDULED VISIT
17 ;
18 ; SDARRAY("DATE NOW") (REQ AT TIME REQUEST MADE)
19 ;
20 ; SDARRAY("LAB DATE TIME ASSOCIATED") =
21 ; "" OR DATE/TIME (OPTIONAL)
22 ;
23 ; SDARRAY("X-RAY DATE TIME ASSOCIATED") =
24 ; "" OR DATE/TIME (OPTIONAL)
25 ;
26 ; SDARRAY("EKG DATE TIME ASSOCIATED") =
27 ; "" OR DATE/TIME (OPTIONAL)
28 ;
29 ; SDARRAY("APPT TYPE") = 9 (REQUIRED)
30 ; 9 for REGULAR APPOINTMENT TYPE
31 ; ptr 409.1
32 ; SDARRAY("APPT SUB-CATEGORY") = "0" (NOT USED)
33 ; "0" for none
34 ; ptr 35.2
35 ;
36 ; SDARRAY("SCHED_REQ_TYPE")='O' (REQUIRED)
37 ; 'O' FOR OTHER THAN 'NEXT AVA.' APPT.;
38 ; set of codes
39 ; SDARRAY("NEXT APPT IND")=0 (REQUIRED)
40 ; 0 FOR NO
41 ; SDARRAY("DESIRED DATE TIME OF APPT")=SD (OPTIONAL)
42 ; SDARRAY("FOLLOWUP VISIT INDICATOR")= (REQUIRED)
43 ; "0" FOR NO
44 ; "1" FOR YES
45 ;
46 ;
47 ;
48 ; SDARRAY("X RAY DATA FREE TEXT")= (OPTIONAL)
49 ; SDARRAY("OTHER DATA FREE TEXT")= (OPTIONAL)
50 ; SDARRAY("OTHER WARD LOCATION")= (OPTIONAL)
51 ;
52 ;
53 ; SDARRAY("DATA ENTRY CLERK")= (REQUIRED)
54 ; DUZ OR NEW PERSON (FILE 200) PTR
55 ;
56 ; SDARRAY("PRIOR XRAY RESULTS TO CLINIC")= (OPTIONAL)
57 ; "Y" OR ""
58 ;
59 ;
60 ; SDARRAY("CHECKED-IN DATE")= (OPTIONAL)
61 ; "" OR DATE APPOINTMENT MADE
62 ; FOR AN UNSCHEDULED VISIT
63 ;
64 ; XQORMUTE ; EXIST AS NON-INTERACTIVE SILENT NODE W/O WRITE FOR XQOR ROUTINES
65 ; SDVWNVAI ; EXIST AS NON-VA RELATED PFSS EVENT MODE
66 ; = "D" DISABLING THE NEED FOR ICN
67 ; = "O" AS OTHER NON-VA ICN SYSTEM ( FUTURE)
68 ;
69 ; Q 1 OK,APPOINTMENT SUCCESSFULLY MADE
70 ; Q NEG NUMBER ERROR
71 ; -101 INVALID PATIENT DFN
72 ; -102 INVALID HOSPITAL LOCATION IEN (SC)
73 ; -103 SD1 < DATE NOW
74 ; -104 INVALID STYP
75 ; -105 I $G(SDARRAY("DATE NOW"))=""
76 ; -106 I $G(SDARRAY("APPT TYPE"))=""
77 ; -107 I $G(SDARRAY("SCHED_REQ_TYPE"))=""
78 ; -108 I $G(SDARRAY("NEXT APPT IND"))=""
79 ; -109 I $G(SDARRAY("DATA ENTRY CLERK"))=""
80 ; -110 I $G(SDARRAY("FOLLOWUP VISIT INDICATOR")=""
81 ; -111 NO SCHEDULED SLOT WHERE SCHED APPT IS WANTED
82 N SD,TIMEDD
83 N SDCL,SDT,SDDA,SDMODE,SDORG
84 N AJJ3CNT,SDY,SDATE,DAYW,AJJ3ONE,AJJ3OVER,AJJ3VAL,MULTM,START,INCRM
85 N TIMED,ILENT,AJJ3MATC,AJJ3OV2,AJJ3VAL2,TIMED
86 N SDSL,SL,SDSDATE,STARTDAY,D,SDHDL,SDEMP,SDMKHDL,SDMADE,SDLOCK,SDAPTYP,SDCOL
87 ;
88 N PURVISIT,SAVENOW,OVERBOOK,ELIGIB,OVERBOKM,AJJ3SAVE
89 ;
90 ;VALIDATE DFN, SC AS VALID PATIENTS AND CLINIC
91 I '$D(^DPT(DFN,0)) Q -101
92 I '$D(^SC(SC,0)) Q -102
93 ;
94 ;
95 ;CHECK DATE>=NOW
96 ;
97 S SD=SD1
98 S X=$G(SDARRAY("DATE NOW")) S SAVENOW=X
99 I SD<SAVENOW Q -103
100 I STYP=4 S SD=X
101 ;FORMAT SD BELOW SHOULD BE FOUND IN NODE BELOW
102 I $G(^SC(SC,"S",SD,0))=SD D
103 .S AJJ3CNT=0
104 .;.F S AJJ3CNT=$O(^SC(SC,"S",DT,1,AJJ3CNT)) Q:AJJ3CNT="" D
105 .F S AJJ3CNT=$O(^SC(SC,"S",SD,1,AJJ3CNT)) Q:AJJ3CNT="" D
106 ..S SDY=AJJ3CNT+1
107 E D
108 .;AJJ3CNT=SDY=1
109 .S SDY=1
110 I (STYP<1)!(STYP>4) Q -104
111 ;
112 ;CHECK OTHER REQUIRED VARIABLES
113 I $G(SDARRAY("DATE NOW"))="" Q -105
114 I $G(SDARRAY("APPT TYPE"))="" Q -106
115 I $G(SDARRAY("SCHED_REQ_TYPE"))="" Q -107
116 I $G(SDARRAY("NEXT APPT IND"))="" Q -108
117 I $G(SDARRAY("DATA ENTRY CLERK"))="" Q -109
118 I $G(SDARRAY("FOLLOWUP VISIT INDICATOR"))="" Q -110
119 ;
120 ;
121 ;
122 S AJJ3OV2=0
123 I STYP'=4 D
124 .;BEFORE MAKE APPT
125 .;THIS MAY ALSO DO CHECKIN AN APPOINTMENT
126 .;ALSO NEED TO CHECK AGAINST SCHEDULE FOR THAT DAY
127 .;DETERMINE LAST RELATIVE ENTRY # FOR
128 .;THIS APPOINTMENT DATE ( IF ANY) ON THIS CLINIC
129 .;
130 .;TO SEE IF OVERBOOK MAX ACHIEVED OR APPOINTMENT NOT AVAILABLE
131 .;FOR THAT TIME AND DATE.
132 .;GET DATE
133 .S SDATE=SD\1
134 .S TIMED=$P(SD,".",2)
135 .S ILENT=$L(TIMED)
136 .F Q:ILENT=4 D
137 ..S TIMED=TIMED_"0" S ILENT=$L(TIMED) ;PAD OUT TIME TO 4 DIGITS
138 .;W !,"TIMED=",TIMED
139 .;CHECK WHAT MULTIPLE OF DAY OF WEEK FOR APPOINTMENT START
140 .;GET DAY OF WEEK
141 .S X=SDATE
142 .D DW^%DTC
143 .I X'="" D
144 ..S DAYW=$E(X,1,2)
145 ..;W !,"DAYW=",X
146 ..S AJJ3ONE=0
147 ..S AJJ3OVER=0
148 ..;FIND DAY OF WEEK ENTRY IN "ST" MULT , THEN FIND STARTING TIME AND
149 ..;TIME MATCH IN SAME "T" MULT.
150 ..S AJJ3MATC=0
151 ..F S AJJ3ONE=$O(^SC(SC,"ST",AJJ3ONE)) Q:(AJJ3ONE="")!(AJJ3OVER'=0) D
152 ...S AJJ3VAL=$G(^SC(SC,"ST",AJJ3ONE,1)) S X2=AJJ3ONE S X1=SDATE D ^%DTC S SDIFF=X I ($E(AJJ3VAL,1,2)=DAYW)&(SDIFF'<0) S AJJ3SAVE=AJJ3ONE I $$CHKAVAIL(AJJ3SAVE,SD) S AJJ3OVER=AJJ3ONE
153 ...;W !,"AJJ3VAL=",AJJ3VAL," AJJ3ONE=",AJJ3ONE," SDATE=",SDATE," SDIFF=",SDIFF
154 ...I AJJ3OVER'=0 D
155 ....S AJJ3INCR=0
156 ....F S AJJ3INCR=$O(^SC(SC,"T",AJJ3OVER,2,AJJ3INCR)) Q:(AJJ3INCR="")!(AJJ3OV2=1) D
157 .....S AJJ3VAL2=$G(^SC(SC,"T",AJJ3OVER,2,AJJ3INCR,0)) S AJJ3VAL2=$P(AJJ3VAL2,"^",1) I AJJ3VAL2=TIMED S AJJ3OV2=1
158 ..I AJJ3OV2'=0 D
159 ...;NOW CHECK IN "S" ARRAY TO SEE IF APPT ALREADY MADE
160 ...I SDY'=1 D
161 ....;CHECK IF OVERBOOKS ALLOWED
162 ....I $P($G(^SC(SC,"SL")),"^",7)=0 S AJJ3OV2=0
163 .E D
164 ..S AJJ3OV2=0
165 E D
166 .;ALSO
167 .S AJJ3OV2=1
168 I AJJ3OV2'=0 D
169 .;
170 .;D NOW^%DTC S X2=X\1 S SAVENOW=X S X1=SDATE D ^%DTC IF X<0 S AJJ3OV2=0
171 .D
172 ..S SDCL=SC
173 ..S SDT=SD
174 ..S SDDA=SDY
175 ..S SDMODE=2
176 ..S SDORG=1
177 ..;ADDITIONAL
178 ..;S SDSL=$P(^SC(SC,"SL"),"^",1) S SL=SDSL S SDXSCAT=0
179 ..S SL=$P(^SC(SC,"SL"),"^",1)
180 ..S SDSDATE=SD
181 ..;S STARTDAY
182 ..;
183 ..;START PREPARING DATA FROM SDARRAY INTO NODES
184 ..;
185 ..;FIRST INITIAL TOP NODE FOR APPOINTMENT SUB-FILE
186 ..S ^DPT(DFN,"S",0)="^2.98P^^"
187 ..L +^DPT(DFN,"S",0):5
188 ..;NEXT NODE 0
189 ..S PURVISIT=STYP
190 ..S TIMEDD=$P(SD,".",1)
191 ..S ^DPT(DFN,"S",SD,0)=SC_"^^"_$G(SDARRAY("LAB DATE TIME ASSOCIATED"))_"^"_$G(SDARRAY("X-RAY DATE TIME ASSOCIATED"))_"^"_$G(SDARRAY("EKG DATE TIME ASSOCIATED"))
192 ..S ^DPT(DFN,"S",SD,0)=^DPT(DFN,"S",SD,0)_"^^"_PURVISIT_"^^^^^^^^^"_$G(SDARRAY("APPT TYPE"))_"^^^"_TIMEDD_"^^^^^"_0
193 ..S ^DPT(DFN,"S",SD,0)=^DPT(DFN,"S",SD,0)_"^"_$G(SDARRAY("SCHED_REQ_TYPE"))_"^"_$G(SDARRAY("NEXT APPT IND"))
194 ..;NEXT NODE 1
195 ..I $G(SDARRAY("DESIRED DATE TIME OF APPT"))'="" D
196 ...S ^DPT(DFN,"S",SD,1)=$G(SDARRAY("DESIRED DATE TIME OF APPT"))_"^"_$G(SDARRAY("FOLLOWUP VISIT INDICATOR"))
197 ..E D
198 ...;
199 ...S ^DPT(DFN,"S",SD,1)=TIMEDD_"^"_$G(SDARRAY("FOLLOWUP VISIT INDICATOR"))
200 ..L -^DPT(DFN,"S",0)
201 ..;NOW FILE 44 MULTIPLE IN APPOINTMENT SUB-FILE
202 ..;FIRST TOP NODE IN CLINIC FOR DATE
203 ..S ^SC(SC,"S",0)="^44.001DA^^"
204 ..L +^SC(SC,"S",0):5
205 ..;NEXT DATE MULTIPLE
206 ..S ^SC(SC,"S",SD,0)=SD
207 ..;NEXT TOP NODE UNDER DATE FOR PATIENT
208 ..S ^SC(SC,"S",SD,1,0)="^44.003PA^^"
209 ..;NEXT MULTIPLE ENTRY PER PATIENT
210 ..S ^SC(SC,"S",SD,1,SDY,0)=DFN_"^"_SL_"^"_$G(SDARRAY("X RAY DATA FREE TEXT"))_"^"_$G(SDARRAY("OTHER DATA FREE TEXT"))_"^"_$G(SDARRAY("OTHER WARD LOCATION"))
211 ..S ^SC(SC,"S",SD,1,SDY,0)=^SC(SC,"S",SD,1,SDY,0)_"^"_$G(SDARRAY("DATA ENTRY CLERK"))_"^"_SAVENOW
212 ..I STYP=4 S ^SC(SC,"S",SD,1,SDY,0)=^SC(SC,"S",SD,1,SDY,0)_"^"_$G(SDARRAY("PRIOR X-RAY RESULTS TO CLINIC"))
213 ..;DETERMINE ANY OVERBOOK AND ELIGIBILITY HERE
214 ..;
215 ..S OVERBOKM=$P(^SC(SC,"SL"),"^",7)
216 ..I SDY>OVERBOKM D
217 ...S OVERBOOK="O"
218 ...S ^SC(SC,"S",SD,1,SDY,"OB")="0"
219 ..E D
220 ...S OVERBOOK=""
221 ..;ELIGIBILITY NEXT
222 ..D ELIG^VADPT S ELIGIB=$P(VAEL(1),"^",1)
223 ..IF STYP=4 S ^SC(SC,"S",SD,1,SDY,0)=^SC(SC,"S",SD,1,SDY,0)_"^"_"^"_"^"_ELIGIB
224 ..;NOW UNSCHEDULED VISITS EXTRA DATA
225 ..;REALLY LATER MAY NEED ELIGIBILITY FOR NON-VA SYSTEMS PATIENTS WITH
226 ..;SCHEDULED APPTS AND UNSCHEDULED VISITS ( HUMANITARIAN, REIMBURSABLE INSURANCE, ETC)
227 ..I STYP=4 D
228 ...S ^SC(SC,"S",SD,1,SDY,"C")=SD_"^"_$G(SDARRAY("DATA ENTRY CLERK"))_"^^^"_SD
229 ..L -^SC(SC,"S",0)
230 ..;EVENT GENERATION ALSO FOR PFSS SYSTEM WHICH CAN BE USED WITH AN EXTERNAL SCHEDULING SYSTEM
231 ..;FOR MAKE APPT EVENTS AS WELL AS CHECKIN,CHECKOUT,CANCEL,DELETE, AND OUTPATIENT ENCOUNTER DATA
232 ..D MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,SDMODE)
233 E Q -111
234 Q 1
235CHKAVAIL(AJJ3SAVE,SD) ;
236 N SL,AJJ3VAL,DATE,STARTTIM,TIMED,ILENT,SL,POS,COUNT
237 ;CHECK IF SLOT ALLOWED FOR THAT DAY/TIME SLOT
238 S SL=$P($G(^SC(SC,"SL")),"^",1) ;LENGTH OF APPT
239 S AJJ3VAL=$G(^SC(SC,"ST",AJJ3SAVE,1))
240 ;START AT 9TH PIECE TO SEE IF NON-BLANK
241 ;FORMAT DATE+STARTTIME
242 S STARTTIM=$P($G(^SC(SC,"SL")),"^",3) ;STARTIM
243 I $L(STARTTIM)=1 S STARTTIM="0"_STARTTIM
244 ;0 PAD TO 4 DIGITS STARTTIM
245 S ILENT=$L(STARTTIM)
246 F Q:ILENT=4 D
247 .S STARTTIM=STARTTIM_"0" S ILENT=$L(STARTTIM) ;PAD OUT TIME TO 4 DIGITS
248 S TIMED=$P(SD,".",2)
249 S ILENT=$L(TIMED)
250 F Q:ILENT=4 D
251 .S TIMED=TIMED_"0" S ILENT=$L(TIMED) ;PAD OUT TIME TO 4 DIGITS
252 S DIFF=TIMED-STARTTIM
253 S SL=$P(^SC(SC,"SL"),"^",1)
254 S COUNT=DIFF/SL
255 S POS=9+2*COUNT
256 I $E(AJJ3VAL,POS,POS)'=" " Q 1
257 Q 0
Note: See TracBrowser for help on using the repository browser.