source: cprs/branches/tmg-cprs/m_files/TMGSDAM2.m@ 1035

Last change on this file since 1035 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 15.5 KB
RevLine 
[796]1TMGSDAM2 ;TMG/kst/ENHANCED MAKE AN APPOINTMENT SDAPI ;1/9/09
2 ;;1.0;TMG-LIB;**1**;1/9/09
3 ;
4 ;"NOTE: Original header:
5 ;"SDVWMKPI ;ENHANCED MAKE AN APPOINTMENT SDAPI 11/18/06
6 ;" ;VWSD*3.2;;;;;Build 8
7 ;"(Moved to this namespace for customization/alteration)
8 ;
9 ;"Called into from TMGRPC5
10 ;
11 ;"=======================================================================
12 ;" API -- Public Functions.
13 ;"=======================================================================
14 ;"EN(DFN,APPTDATE,SC,STYP,SDARRAY) -- MAKE AN APPOINTMENT
15 ;
16 ;"=======================================================================
17 ;" API -- Public Functions.
18 ;"=======================================================================
19 ;"CHKAVAIL(SAVE,APPTDATE)
20 ;
21 ;"=======================================================================
22 ;"Dependancies
23 ;"=======================================================================
24 ;
25 ;"=======================================================================
26 ;
27EN(DFN,APPTDATE,SC,STYP,SDARRAY) ;
28 ;"Purpose: MAKE AN APPOINTMENT
29 ;"INPUT: DFN -- PATIENT IEN (REQUIRED)
30 ;" APPTDATE -- APPOINTMENT DATE (REQUIRED) -- FM format
31 ;" SC -- IEN of CLINIC FOR APPOINTMENT (REQUIRED) (file 44)
32 ;" STYP (REQUIRED)
33 ;" =1 C&P
34 ;" =2 10-10
35 ;" =3 SCHEDULED APPOINTMENT
36 ;" =4 UNSCHEDULED VISIT
37 ;" SDARRAY -- PASS BY REFERENCE. Format:
38 ;" SDARRAY("DATE NOW") (REQ AT TIME REQUEST MADE) (OPTIONAL. Defaults to NOW is not provide)
39 ;" SDARRAY("LAB DATE TIME ASSOCIATED") = "" OR DATE/TIME (OPTIONAL)
40 ;" SDARRAY("X-RAY DATE TIME ASSOCIATED") = "" OR DATE/TIME (OPTIONAL)
41 ;" SDARRAY("EKG DATE TIME ASSOCIATED") = "" OR DATE/TIME (OPTIONAL)
42 ;" SDARRAY("APPT TYPE") = 9 (REQUIRED)
43 ;" 9 for REGULAR APPOINTMENT TYPE (ptr 409.1)
44 ;" SDARRAY("APPT SUB-CATEGORY") = "0" (NOT USED)
45 ;" "0" for none (ptr 35.2)
46 ;" SDARRAY("SCHED_REQ_TYPE")='O' (REQUIRED)
47 ;" 'O' FOR OTHER THAN 'NEXT AVA.' APPT.; (set of codes)
48 ;" --I think this is for File 2, field 1900, subfield 25
49 ;" N:'NEXT AVAILABLE' APPT.
50 ;" C:OTHER THAN 'NEXT AVA.' (CLINICIAN REQ.)
51 ;" P:OTHER THAN 'NEXT AVA.' (PATIENT REQ.)
52 ;" W:WALKIN APPT.
53 ;" M:MULTIPLE APPT. BOOKING
54 ;" A:AUTO REBOOK
55 ;" O:OTHER THAN 'NEXT AVA.' APPT.
56 ;" SDARRAY("NEXT APPT IND")=0 (REQUIRED) (0 FOR NO)
57 ;" SDARRAY("DESIRED DATE TIME OF APPT")=APPTDATE (OPTIONAL)
58 ;" SDARRAY("FOLLOWUP VISIT INDICATOR")= (REQUIRED)
59 ;" "0" FOR NO
60 ;" "1" FOR YES
61 ;" SDARRAY("X RAY DATA FREE TEXT")= (OPTIONAL)
62 ;" SDARRAY("OTHER DATA FREE TEXT")= (OPTIONAL)
63 ;" SDARRAY("OTHER WARD LOCATION")= (OPTIONAL)
64 ;" SDARRAY("DATA ENTRY CLERK")= (DEFAULTS TO DUZ IF NOT PROVIDED)
65 ;" DUZ OR NEW PERSON (FILE 200) PTR
66 ;" SDARRAY("PRIOR XRAY RESULTS TO CLINIC")= (OPTIONAL)
67 ;" "Y" OR ""
68 ;" SDARRAY("CHECKED-IN DATE")= (OPTIONAL)
69 ;" "" OR DATE APPOINTMENT MADE
70 ;" FOR AN UNSCHEDULED VISIT
71 ;"
72 ;"XQSDVWSI ; EXIST AS NON-INTERACTIVE SILENT NODE W/O WRITE FOR XQOR ROUTINES
73 ;"SDVWNVAI ; EXIST AS NON-VA RELATED PFSS EVENT MODE
74 ;" = "D" DISABLING THE NEED FOR ICN
75 ;" = "O" AS OTHER NON-VA ICN SYSTEM ( FUTURE)
76 ;"
77 ;"RESULTS: 1 = OK,APPOINTMENT SUCCESSFULLY MADE
78 ;" NEG NUMBER= ERROR
79 ;" -101 INVALID PATIENT DFN
80 ;" -102 INVALID HOSPITAL LOCATION IEN (SC)
81 ;" -103 APPTDATE < DATE NOW
82 ;" -104 INVALID STYP or MODE
83 ;" // (removed) -105 IF $GET(SDARRAY("DATE NOW"))=""
84 ;" -106 IF $GET(SDARRAY("APPT TYPE"))=""
85 ;" -107 IF $GET(SDARRAY("SCHED_REQ_TYPE"))=""
86 ;" -108 IF $GET(SDARRAY("NEXT APPT IND"))=""
87 ;" // (removed) -109 IF $GET(SDARRAY("DATA ENTRY CLERK"))=""
88 ;" -110 IF $GET(SDARRAY("FOLLOWUP VISIT INDICATOR")=""
89 ;" -111 NO SCHEDULED SLOT WHERE SCHED APPT IS WANTED
90 ;
91 N TIMEDD
92 N SDCL,SDT,SDDA,SDMODE,SDORG
93 N CNT,SDY,DAYW,NDOW,TMG1DATE,FOUND,VAL,MULTM,START,INCRM
94 N APTTIME,OV2,VAL2
95 N SDSL,SL,SDSDATE,STARTDAY,SDHDL,SDEMP,SDMKHDL,SDMADE,SDLOCK,SDAPTYP,SDCOL
96 N TMGRESULT SET TMGRESULT=1 ;"Default to success
97 N TMGMSG
98 ;
99 N PURVISIT,SAVENOW,OVERBOOK,ELIGIB,OVERBOKM
100 ;
101 ;"VALIDATE DFN, SC AS VALID PATIENTS AND CLINIC
102 IF '$D(^DPT(DFN,0)) SET TMGRESULT="-101^INVALID PATIENT DFN" GOTO ENDONE
103 IF '$D(^SC(SC,0)) SET TMGRESULT="-102^INVALID HOSPITAL LOCATION IEN" GOTO ENDONE
104 ;
105 ;"CHECK DATE>=NOW
106 IF $GET(SDARRAY("DATE NOW"))="" SET SDARRAY("DATE NOW")="NOW"
107 . ;"SET TMGRESULT=-105 GOTO ENDONE
108 SET SDARRAY("DATE NOW")=$$E2IDATE(SDARRAY("DATE NOW"))
109 SET (SAVENOW,X)=SDARRAY("DATE NOW")
110 IF APPTDATE<SAVENOW SET TMGRESULT="-103^APPTDATE < DATE NOW" GOTO ENDONE
111 IF STYP=4 SET APPTDATE=X ;"If unscheduled visit, force date to NOW
112 ;"FORMAT APPTDATE BELOW SHOULD BE FOUND IN NODE BELOW
113 IF $GET(^SC(SC,"S",APPTDATE,0))=APPTDATE DO
114 . SET CNT=0
115 . FOR SET CNT=$ORDER(^SC(SC,"S",APPTDATE,1,CNT)) Q:CNT="" DO
116 . . SET SDY=CNT+1
117 ELSE DO
118 . SET SDY=1
119 IF (STYP<1)!(STYP>4) SET TMGRESULT="-104^INVALID STYP or MODE" GOTO ENDONE
120 ;
121 IF $GET(SDARRAY("DATA ENTRY CLERK"))="" DO
122 . SET SDARRAY("DATA ENTRY CLERK")=DUZ
123 . ;"SET TMGRESULT=-109 GOTO ENDONE
124 ;
125 ;"CHECK OTHER REQUIRED VARIABLES
126 IF $GET(SDARRAY("APPT TYPE"))="" DO GOTO ENDONE
127 . SET TMGRESULT="-106^APPT TYPE NOT SPECIFIED"
128 IF $GET(SDARRAY("SCHED_REQ_TYPE"))="" DO GOTO ENDONE
129 . SET TMGRESULT="-107^SCHED REQ TYPE NOT SPECIFIED"
130 IF $GET(SDARRAY("NEXT APPT IND"))="" DO GOTO ENDONE
131 . SET TMGRESULT="-108^NEXT APPT IND NOT SPECIFIED"
132 IF $GET(SDARRAY("FOLLOWUP VISIT INDICATOR"))="" DO GOTO ENDONE
133 . SET TMGRESULT="-110^FOLLOWUP VISIT INDICATOR NOT SPECIFIED"
134 ;
135 ;"ENSURE EXISTANCE OF VARIABLES / CONVERT DATES IF NEEDED
136 SET SDARRAY("CHECKED-IN DATE")=$$E2IDATE($GET(SDARRAY("CHECKED-IN DATE")))
137 SET SDARRAY("LAB DATE TIME ASSOCIATED")=$$E2IDATE($GET(SDARRAY("LAB DATE TIME ASSOCIATED")))
138 SET SDARRAY("X-RAY DATE TIME ASSOCIATED")=$$E2IDATE($GET(SDARRAY("X-RAY DATE TIME ASSOCIATED")))
139 SET SDARRAY("EKG DATE TIME ASSOCIATED")=$$E2IDATE($GET(SDARRAY("EKG DATE TIME ASSOCIATED")))
140 SET SDARRAY("APPT TYPE")=$GET(SDARRAY("APPT TYPE"))
141 SET SDARRAY("SCHED_REQ_TYPE")=$GET(SDARRAY("SCHED_REQ_TYPE"))
142 SET SDARRAY("NEXT APPT IND")=$GET(SDARRAY("NEXT APPT IND"))
143 SET SDARRAY("DESIRED DATE TIME OF APPT")=$$E2IDATE($GET(SDARRAY("DESIRED DATE TIME OF APPT")))
144 SET SDARRAY("FOLLOWUP VISIT INDICATOR")=$GET(SDARRAY("FOLLOWUP VISIT INDICATOR"))
145 SET SDARRAY("FOLLOWUP VISIT INDICATOR")=$GET(SDARRAY("FOLLOWUP VISIT INDICATOR"))
146 ;
147 SET OV2=0
148 IF STYP'=4 DO ;"i.e. 1 (C&P), 2 (10-10), or 3 (SCHEDULED APPOINTMENT)
149 . ;"BEFORE MAKE APPT
150 . ;"THIS MAY ALSO DO CHECKIN AN APPOINTMENT
151 . ;"ALSO NEED TO CHECK AGAINST SCHEDULE FOR THAT DAY
152 . ;"DETERMINE LAST RELATIVE ENTRY # FOR
153 . ;"THIS APPOINTMENT DATE (IF ANY) ON THIS CLINIC
154 . ;
155 . ;"TO SEE IF OVERBOOK MAX ACHIEVED OR APPOINTMENT NOT AVAILABLE
156 . ;"FOR THAT TIME AND DATE.
157 . ;"GET DATE
158 . SET APTTIME=$P(APPTDATE,".",2) ;"get just time
159 . FOR Q:$L(APTTIME)>3 SET APTTIME=APTTIME_"0" ;"PAD OUT TIME TO 4 DIGITS
160 . ;"CHECK WHAT MULTIPLE OF DAY OF WEEK FOR APPOINTMENT START
161 . ;"GET DAY OF WEEK
162 . SET X=APPTDATE DO DW^%DTC IF X="" QUIT ;"Must be invalid date
163 . SET DAYW=$E(X,1,2) ;"e.g. MO for MONDAY
164 . SET DOW=$$DOW^XLFDT(APPTDATE,1) ;"DOW=Day of Week (0-6)
165 . ;"FIND DAY OF WEEK ENTRY IN "ST" MULT , THEN FIND STARTING TIME AND
166 . ;"TIME MATCH IN SAME "T" MULT.
167 . SET TMG1DATE=APPTDATE\1
168 . SET FOUND=0
169 . FOR DO SET TMG1DATE=$ORDER(^SC(SC,"ST",TMG1DATE),-1) QUIT:(+TMG1DATE'>0)!(FOUND=1)
170 . . SET VAL=$GET(^SC(SC,"ST",TMG1DATE,1)) ;" e.g. MO 05 | [1 1|0 1 1 1|1 1 1 1|1 1] "
171 . . IF ($E(VAL,1,2)'=DAYW) QUIT ;"Skip if null, or not matching day of week
172 . . IF $$CHKAVAIL(TMG1DATE,APTTIME)=0 QUIT
173 . . SET FOUND=1
174 . . SET INCR=0
175 . . ;"Now find T node that applies to APPTDATE
176 . . NEW TEMPDATE SET TEMPDATE=TMG1DATE
177 . . FOR DO QUIT:(OV2=1) SET TEMPDATE=$ORDER(^SC(SC,"T",TEMPDATE),-1) QUIT:(+TEMPDATE'>0)
178 . . . IF $DATA(^SC(SC,"T",TEMPDATE))=0 QUIT
179 . . . IF $$DOW^XLFDT(TEMPDATE,1)'=DOW QUIT
180 . . . FOR SET INCR=$ORDER(^SC(SC,"T",TEMPDATE,2,INCR)) QUIT:(INCR="")!(OV2=1) DO
181 . . . . SET VAL2=$GET(^SC(SC,"T",TEMPDATE,2,INCR,0)) ;"e.g. 0830^1
182 . . . . SET VAL2=$PIECE(VAL2,"^",1)
183 . . . . IF VAL2=APTTIME SET OV2=1
184 . IF OV2=1 DO
185 . . ;"NOW CHECK IN "S" ARRAY TO SEE IF APPT ALREADY MADE
186 . . IF SDY'=1 DO ;"Should this be SDY>1 DO ??
187 . . . ;"CHECK IF OVERBOOKS ALLOWED
188 . . . IF $PIECE($GET(^SC(SC,"SL")),"^",7)=0 SET OV2=0
189 ELSE DO ;"i.e. STYP=4 UNSCHEDULED VISIT
190 . ;"ALSO
191 . SET OV2=1
192 ;
193 IF OV2'=1 DO GOTO ENDONE
194 . SET TMGRESULT="-111^NO SCHEDULED SLOT WHERE SCHED APPT IS WANTED"
195 ;
196 SET SDCL=SC
197 SET SDT=APPTDATE
198 SET SDDA=SDY
199 SET SDMODE=2
200 SET SDORG=1
201 ;"ADDITIONAL
202 SET SL=$P(^SC(SC,"SL"),"^",1)
203 SET SDSDATE=APPTDATE
204 ;"SET STARTDAY
205 ;
206 ;"START PREPARING DATA FROM SDARRAY INTO NODES
207 ;
208 ;"FIRST INITIAL TOP NODE FOR APPOINTMENT SUB-FILE
209 SET ^DPT(DFN,"S",0)="^2.98P^^"
210 LOCK +^DPT(DFN,"S",0):5
211 ;"NEXT NODE 0
212 SET PURVISIT=STYP
213 SET TIMEDD=$P(APPTDATE,".",1)
214 NEW TEMPS
215 SET TEMPS=SC_"^^"_SDARRAY("LAB DATE TIME ASSOCIATED")_"^"
216 SET TEMPS=TEMPS_SDARRAY("X-RAY DATE TIME ASSOCIATED")_"^"
217 SET TEMPS=TEMPS_SDARRAY("EKG DATE TIME ASSOCIATED")
218 SET ^DPT(DFN,"S",APPTDATE,0)=TEMPS
219 SET TEMPS=^DPT(DFN,"S",APPTDATE,0)_"^^"_PURVISIT
220 SET TEMPS=TEMPS_"^^^^^^^^^"_SDARRAY("APPT TYPE")_"^^^"_TIMEDD_"^^^^^"_0
221 SET ^DPT(DFN,"S",APPTDATE,0)=TEMPS
222 SET TEMPS=^DPT(DFN,"S",APPTDATE,0)_"^"_SDARRAY("SCHED_REQ_TYPE")_"^"
223 SET TEMPS=TEMPS_SDARRAY("NEXT APPT IND")
224 SET ^DPT(DFN,"S",APPTDATE,0)=TEMPS
225 ;"NEXT NODE 1
226 IF SDARRAY("DESIRED DATE TIME OF APPT")'="" DO
227 . SET ^DPT(DFN,"S",APPTDATE,1)=SDARRAY("DESIRED DATE TIME OF APPT")_"^"_SDARRAY("FOLLOWUP VISIT INDICATOR")
228 ELSE DO
229 . SET ^DPT(DFN,"S",APPTDATE,1)=TIMEDD_"^"_SDARRAY("FOLLOWUP VISIT INDICATOR")
230 LOCK -^DPT(DFN,"S",0)
231 ;"NOW FILE 44 MULTIPLE IN APPOINTMENT SUB-FILE
232 ;"FIRST TOP NODE IN CLINIC FOR DATE
233 SET ^SC(SC,"S",0)="^44.001DA^^"
234 LOCK +^SC(SC,"S",0):5
235 ;"NEXT DATE MULTIPLE
236 SET ^SC(SC,"S",APPTDATE,0)=APPTDATE
237 ;"NEXT TOP NODE UNDER DATE FOR PATIENT
238 SET ^SC(SC,"S",APPTDATE,1,0)="^44.003PA^^"
239 ;"NEXT MULTIPLE ENTRY PER PATIENT
240 SET ^SC(SC,"S",APPTDATE,1,SDY,0)=DFN_"^"_SL_"^"_$GET(SDARRAY("X RAY DATA FREE TEXT"))_"^"_$GET(SDARRAY("OTHER DATA FREE TEXT"))_"^"_$GET(SDARRAY("OTHER WARD LOCATION"))
241 SET ^SC(SC,"S",APPTDATE,1,SDY,0)=^SC(SC,"S",APPTDATE,1,SDY,0)_"^"_$GET(SDARRAY("DATA ENTRY CLERK"))_"^"_SAVENOW
242 IF STYP=4 SET ^SC(SC,"S",APPTDATE,1,SDY,0)=^SC(SC,"S",APPTDATE,1,SDY,0)_"^"_$GET(SDARRAY("PRIOR X-RAY RESULTS TO CLINIC"))
243 ;
244 ;"Change PATTERN ("ST") nodes to reflext currently available slots.
245 IF $$ENSUR1ST^TMGSDAU(SC,APPTDATE,.TMGMSG)'=1 DO ;"Create ST node, if doesn't exist
246 . SET TMGRESULT="-200^"_$GET(TMGMSG(1)) KILL TMGMSG
247 IF $$DEC1SLOT^TMGSDAU(SC,APPTDATE,.TMGMSG)=-1 DO ;"Don't quit, appt was made-->so trigger event
248 . SET TMGRESULT="-200^Error updating PATTERN (ST nodes). "_$GET(TMGMSG(1))
249 . KILL TMGMSG
250 ;
251 ;"DETERMINE ANY OVERBOOK AND ELIGIBILITY HERE
252 SET OVERBOKM=$P(^SC(SC,"SL"),"^",7)
253 IF SDY>OVERBOKM DO
254 . SET OVERBOOK="O"
255 . SET ^SC(SC,"S",APPTDATE,1,SDY,"OB")="0"
256 ELSE DO
257 . SET OVERBOOK=""
258 ;"ELIGIBILITY NEXT
259 DO ELIG^VADPT SET ELIGIB=$P(VAEL(1),"^",1)
260 IF STYP=4 SET ^SC(SC,"S",APPTDATE,1,SDY,0)=^SC(SC,"S",APPTDATE,1,SDY,0)_"^"_"^"_"^"_ELIGIB
261 ;"NOW UNSCHEDULED VISITS EXTRA DATA
262 ;"REALLY LATER MAY NEED ELIGIBILITY FOR NON-VA SYSTEMS PATIENTS WITH
263 ;"SCHEDULED APPTS AND UNSCHEDULED VISITS ( HUMANITARIAN, REIMBURSABLE INSURANCE, ETC)
264 IF STYP=4 DO
265 .SET ^SC(SC,"S",APPTDATE,1,SDY,"C")=SD_"^"_$GET(SDARRAY("DATA ENTRY CLERK"))_"^^^"_SD
266 LOCK -^SC(SC,"S",0)
267 ;"EVENT GENERATION ALSO FOR PFSS SYSTEM WHICH CAN BE USED WITH AN EXTERNAL SCHEDULING SYSTEM
268 ;"FOR MAKE APPT EVENTS AS WELL AS CHECKIN,CHECKOUT,CANCEL,DELETE, AND OUTPATIENT ENCOUNTER DATA
269 DO MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,SDMODE)
270ENDONE ;
271 QUIT TMGRESULT
272 ;
273 ;
274CHKAVAIL(TMG1DATE,APTTIME) ;
275 ;"Purpose: CHECK IF SLOT ALLOWED FOR THAT DAY/TIME SLOT
276 ;"Input TMG1DATE -- DATE in FM format to check on.
277 ;" APTTIME -- Time of appt, in military format, e.g. '1345'
278 ;"Globally Scoped Vars used: SC - IEN in 44
279 ;"Results: 0 -- not available
280 ;" 1 -- available
281 ;
282 N SL,VAL,DATE,STARTTIM,SL,POS,COUNT
283 NEW CODES SET CODES="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
284 ;
285 SET SL=$P($GET(^SC(SC,"SL")),"^",1) ;"LENGTH OF APPT
286 SET VAL=$GET(^SC(SC,"ST",TMG1DATE,1)) ;" e.g. 'MO 05 | [1 1|0 1 1 1|1 1 1 1|1 1] '
287 ;"START AT 9TH PIECE TO SEE IF NON-BLANK
288 ;"FORMAT DATE+STARTTIME
289 SET STARTTIM=$P($GET(^SC(SC,"SL")),"^",3) ;"DISPLAY START TIME
290 IF $L(STARTTIM)=1 SET STARTTIM="0"_STARTTIM
291 FOR Q:$L(STARTTIM)>3 SET STARTTIM=STARTTIM_"0" ;"PAD OUT TIME TO 4 DIGITS
292 FOR Q:$L(APTTIME)>3 SET APTTIME=APTTIME_"0" ;"PAD OUT TIME TO 4 DIGITS
293 ;"SET DIFF=APTTIME-STARTTIM
294 SET DIFF=$$MILDELTA^TMGSDAU1(STARTTIM,APTTIME)
295 ;"SET SL=$P(^SC(SC,"SL"),"^",1)
296 SET COUNT=DIFF/SL
297 SET POS=9+(2*COUNT)
298 ;"IF $E(VAL,POS,POS)'=" " Q 1
299 NEW CH SET CH=$E(VAL,POS,POS)
300 NEW NUMAVAIL SET NUMAVAIL=$FIND(CODES,CH)-$FIND(CODES,"0")
301 IF NUMAVAIL>0 QUIT 1
302 QUIT 0
303 ;
304E2IDATE(TMGDATE)
305 ;"Purpose: To return a FM-format Date from TMGDATE, converting if needed.
306 ;"Input: TMGDATE: A date in external format, or FM-Date format
307 ;" Note: if date is invalid, then "" is returned.
308 NEW TMGRESULT SET TMGRESULT=$GET(TMGDATE)
309 IF (TMGRESULT'=""),(+TMGRESULT'=TMGRESULT) DO
310 . NEW MSG
311 . DO DT^DILF("T",TMGDATE,.MSG)
312 . SET TMGRESULT=MSG
313 QUIT TMGRESULT
314 ;
Note: See TracBrowser for help on using the repository browser.