source: Scheduling/trunk/m/BSDX07.m@ 951

Last change on this file since 951 was 951, checked in by Sam Habiel, 14 years ago

Change version to 1.4 on all routines
BSDX08 has fix for drag and drop because it referenced a non existent cancellation reason
File size: 9.3 KB
Line 
1BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 7/18/10 2:11pm
2 ;;1.4;BSDX;;Sep 07, 2010
3 ;
4 ; Change Log:
5 ; UJO/SMH
6 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
7 ;
8 ;
9APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
10 ;Entry point for debugging
11 ;
12 I +$G(^HWDEBUG("BREAK","APPADD")),+$G(^HWDEBUG("BREAK"))=DUZ D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)",$P(^HWDEBUG("BREAK"),U,2))
13 E G ENDBG
14 Q
15 ;
16APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
17 ;Called by BSDX ADD NEW APPOINTMENT
18 ;Add new appointment
19 ;BSDXRES is ResourceName
20 ;BSDXLEN is the appointment duration in minutes
21 ;BSDXATID is used for 2 purposes:
22 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
23 ; if BSDXATID = a number, then it is the access type id (used for rebooking)
24 ;
25 ;Create entry in BSDX APPOINTMENT
26 ;Returns recordset having fields
27 ; AppointmentID and ErrorNumber
28 ;
29 ;Test lines:
30ENDBG ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^2^PEDIATRICIAN,DEMO^EXAM^SCRATCH NOTE
31 ;
32 N BSDXERR,BSDXIEN,BSDXDEP,BSDXI,BSDXJ,BSDXAPPTI,BSDXDJ,BSDXRESD,BSDXRNOD,BSDXSCD,BSDXC,BSDXERR,BSDXWKIN
33 N BSDXNOEV
34 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
35 K ^BSDXTMP($J)
36 S X="ETRAP^BSDX07",@^%ZOSF("TRAP")
37 S BSDXERR=0
38 S BSDXI=0
39 S BSDXY="^BSDXTMP("_$J_")"
40 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00020ERRORID"_$C(30)
41 S BSDXI=BSDXI+1
42 ;
43 ;Lock BSDX node
44 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later") Q
45 ;
46 TSTART
47 ; v1.3 - date passed in as FM Date, not US date.
48 ;Check input data for errors
49 ; S:BSDXSTART["@0000" BSDXSTART=$P(BSDXSTART,"@")
50 ; S:BSDXEND["@0000" BSDXEND=$P(BSDXEND,"@")
51 ; S %DT="T",X=BSDXSTART D ^%DT S BSDXSTART=Y
52 ; I BSDXSTART=-1 D ERR(BSDXI+1,"BSDX07 Error: Invalid Start Time") Q
53 ; S %DT="T",X=BSDXEND D ^%DT S BSDXEND=Y
54 ; I BSDXEND=-1 D ERR(BSDXI+1,"BSDX07 Error: Invalid End Time") Q
55 ;
56 ; If C# sends the dates with extra zeros, remove them
57 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
58 ;
59 I $L(BSDXEND,".")=1 D ERR(BSDXI+1,"BSDX07 Error: Invalid End Time") Q
60 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
61 I '+BSDXPATID,'$D(^DPT(BSDXPATID,0)) D ERR(BSDXI+1,"BSDX07 Error: Invalid Patient ID") Q
62 ;Validate Resource entry
63 S BSDXERR=0 K BSDXRESD
64 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI+1,"BSDX07 Error: Invalid Resource ID") Q
65 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
66 S BSDXWKIN=0
67 I BSDXATID="WALKIN" S BSDXWKIN=1
68 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
69 ;
70 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
71 I 'BSDXAPPTID D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
72 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
73 ;
74 ;Create RPMS Appointment
75 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
76 ;I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry."),BSDXDEL(BSDXAPPTID) Q
77 I BSDXRNOD="" D ERR(BSDXI+1,"BSDX07 Error: Unable to add appointment -- invalid Resource entry.") Q
78 S BSDXSCD=$P(BSDXRNOD,U,4)
79 ;I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR),BSDXDEL(BSDXAPPTID) Q
80 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI+1,"BSDX07 Error: Unable to make appointment. MAKE^BSDAPI returned error code: "_BSDXERR) Q
81 . S BSDXC("PAT")=BSDXPATID
82 . S BSDXC("CLN")=BSDXSCD
83 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
84 . S:BSDXWKIN BSDXC("TYP")=4
85 . S BSDXC("ADT")=BSDXSTART
86 . S BSDXC("LEN")=BSDXLEN
87 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
88 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDAPI
89 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
90 . S BSDXC("USR")=DUZ
91 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
92 . Q:BSDXERR
93 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
94 . ;L
95 . Q
96 ;
97 ;Update RPMS Clinic availability
98 ;Return Recordset
99 TCOMMIT
100 L -^BSDXAPPT(BSDXPATID)
101 S BSDXI=BSDXI+1
102 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
103 S BSDXI=BSDXI+1
104 S ^BSDXTMP($J,BSDXI)=$C(31)
105 Q
106BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
107 N DA,DIK
108 S DIK="^BSDXAPPT(",DA=BSDXAPPTID
109 D ^DIK
110 Q
111 ;
112STRIP(BSDXZ) ;Replace control characters with spaces
113 N BSDXI
114 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
115 Q BSDXZ
116 ;
117BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
118 ;Returns ien in BSDXAPPT or 0 if failed
119 ;Create entry in BSDX APPOINTMENT
120 N BSDXAPPTID
121 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
122 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
123 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
124 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
125 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
126 ;S BSDXFDA(9002018.4,"+1,",.09)=$G(DT) ;MJL 1/25/2007
127 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
128 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
129 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
130 K BSDXIEN,BSDXMSG
131 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
132 S BSDXAPPTID=+$G(BSDXIEN(1))
133 Q BSDXAPPTID
134 ;
135BSDXWP(BSDXAPPTID,BSDXNOTE) ;
136 ;Add WP field
137 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
138 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
139 I $D(BSDXNOTE(.5)) D
140 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
141 Q
142 ;
143ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
144 ;Called by BSDX ADD APPOINTMENT protocol
145 ;BSDXSC=IEN of clinic in ^SC
146 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
147 ;
148 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
149 Q:+$G(BSDXNOEV)
150 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
151 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
152 Q:'+$G(BSDXRES)
153 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
154 Q:BSDXNOD=""
155 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
156 S BSDXWKIN=""
157 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
158 S BSDXLEN=$P(BSDXNOD,U,2)
159 Q:'+BSDXLEN
160 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
161 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
162 Q:'+BSDXAPPTID
163 S BSDXNOTE=$P(BSDXNOD,U,4)
164 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
165 D ADDEVT3(BSDXRES)
166 Q
167 ;
168ADDEVT3(BSDXRES) ;
169 ;Call RaiseEvent to notify GUI clients
170 N BSDXRESN
171 S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
172 Q:BSDXRESN=""
173 S BSDXRESN=$P(BSDXRESN,"^")
174 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
175 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
176 Q
177 ;
178ERR(BSDXI,BSDXERR) ;Error processing
179 D ^%ZTER ;XXX: remove after we figure out the cause of error
180 S BSDXI=BSDXI+1
181 S BSDXERR=$TR(BSDXERR,"^","~")
182 TROLLBACK
183 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
184 S BSDXI=BSDXI+1
185 S ^BSDXTMP($J,BSDXI)=$C(31)
186 L
187 Q
188 ;
189ETRAP ;EP Error trap entry
190 D ^%ZTER
191 I '$D(BSDXI) N BSDXI S BSDXI=999999
192 S BSDXI=BSDXI+1
193 D ERR(BSDXI,"BSDX07 Error: "_$G(%ZTERROR))
194 Q
195 ;
196DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
197 ;
198DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
199 F %=%:-1:281 S Y=%#4=1+1+Y
200 S Y=$E(X,6,7)+Y#7
201 Q
202 ;
203AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
204 ;SEE SDM1
205 N Y,DFN
206 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
207 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
208 S Y=BSDXSCD,DFN=BSDXPATID
209 S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
210 ;Determine maximum days for scheduling
211 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
212 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
213 S SDDATE=BSDXSTART
214 S SDSDATE=SDDATE,SDDATE=SDDATE\1
2151 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
216 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
217 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
218 S X2=SDEDT D C^%DTC S SDEDT=X
219 S Y=BSDXSTART
220EN1 S (X,SD)=Y,SM=0 D DOW
221S I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0 Q:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
222 S S=BSDXLEN
223 ;Check if BSDXLEN evenly divisible by appointment length
224 S RPMSL=$P(SL,U)
225 I BSDXLEN<RPMSL S BSDXLEN=RPMSL
226 I BSDXLEN#RPMSL'=0 D
227 . S BSDXINC=BSDXLEN\RPMSL
228 . S BSDXINC=BSDXINC+1
229 . S BSDXLEN=RPMSL*BSDXINC
230 S SL=S_U_$P(SL,U,2,99)
231SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
232 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
233 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
234 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
235 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
236 I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
237 ;
238SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
239 S SDNOT=1
240 S ABORT=0
241 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
242 . S ST=$E(S,I+1) S:ST="" ST=" "
243 . S Y=$E(STR,$F(STR,ST)-2)
244 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
245 . I Y="" S ABORT=1 Q
246 . S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
247 . Q
248 S ^SC(SC,"ST",$P(SD,"."),1)=S
249 L -^SC(SC,"ST",$P(SD,"."),1)
250 Q
Note: See TracBrowser for help on using the repository browser.