Changeset 1625 for Scheduling/trunk/m/BSDX07.m
- Timestamp:
- Jun 1, 2013, 10:54:38 AM (11 years ago)
- File:
-
- 1 edited
-
Scheduling/trunk/m/BSDX07.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
Scheduling/trunk/m/BSDX07.m
r1563 r1625 1 BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am 2 ;;1.6;BSDX;;Aug 31, 2011;Build 25 3 ; Licensed under LGPL 4 ; 5 ; Change Log: 6 ; UJO/SMH 7 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US. 8 ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments 9 ; thanks to Rick Marshall and Zach Gonzalez at Oroville. 10 ; v1.42 Oct 30 2010 - Extensive refactoring. 11 ; v1.5 Mar 15 2011 - End time does not have to have time anymore. 12 ; It could be midnight of the next day 13 ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams... 14 ; 15 ; Error Reference: 16 ; -1: Patient Record is locked. This means something is wrong!!!! 17 ; -2: Start Time is not a valid Fileman date 18 ; -3: End Time is not a valid Fileman date 19 ; v1.5:obsolete::-4: End Time does not have time inside of it. 20 ; -5: BSDXPATID is not numeric 21 ; -6: Patient Does not exist in ^DPT 22 ; -7: Resource Name does not exist in B index of BSDX RESOURCE 23 ; -8: Resouce doesn't exist in ^BSDXRES 24 ; -9: Couldn't add appointment to BSDX APPOINTMENT 25 ; -10: Couldn't add appointment to files 2 and/or 44 26 ; -100: Mumps Error 27 1 BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:02pm 2 ;;1.7;BSDX;;Jun 01, 2013;Build 24 3 ; Licensed under LGPL 4 ; 5 ; Change Log: 6 ; UJO/SMH 7 ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US. 8 ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments 9 ; v1.42 Oct 30 2010 - Extensive refactoring. 10 ; v1.5 Mar 15 2011 - End time does not have to have time anymore. 11 ; It could be midnight of the next day 12 ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams... 13 ; v1.7 Jun 20 2012 - Refactoring to remove transactions - many changes 14 ; - AVUPDT moved to AVUPDTMK in BSDXAPI1 15 ; 16 ; Error Reference: 17 ; -1: Patient Record is locked. This means something is wrong!!!! 18 ; -2: Start Time is not a valid Fileman date 19 ; -3: End Time is not a valid Fileman date 20 ; v1.5:obsolete::-4: End Time does not have time inside of it. 21 ; -5: BSDXPATID is not numeric 22 ; -6: Patient Does not exist in ^DPT 23 ; -7: Resource Name does not exist in B index of BSDX RESOURCE 24 ; -8: Resouce doesn't exist in ^BSDXRES 25 ; -9: Couldn't add appointment to BSDX APPOINTMENT 26 ; -10: Couldn't add appointment to files 2 and/or 44 27 ; -100: Mumps Error 28 ; 28 29 APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP 29 ;Entry point for debugging 30 D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)") 31 Q 32 ; 33 UT ; Unit Tests 34 N ZZZ 35 ; Test for bad start date 36 D APPADD(.ZZZ,2100123,3100123.3,2,"Dr Office",30,"Sam's Note",1) 37 I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",! 38 ; Test for bad end date 39 D APPADD(.ZZZ,3100123,2100123.3,2,"Dr Office",30,"Sam's Note",1) 40 I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",! 41 ; Test for end date without time 42 D APPADD(.ZZZ,3100123.1,3100123,2,"Dr Office",30,"Sam's Note",1) 43 I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",! 44 ; Test for mumps error 45 S bsdxdie=1 46 D APPADD(.ZZZ,3100123.09,3100123.093,2,"Dr Office",30,"Sam's Note",1) 47 I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",! 48 K bsdxdie 49 ; Test for TRESTART 50 s bsdxrestart=1 51 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 52 I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",! 53 k bsdxrestart 54 ; Test for non-numeric patient 55 D APPADD(.ZZZ,3100123.09,3100123.093,"CAT,DOG","Dr Office",30,"Sam's Note",1) 56 I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",! 57 ; Test for a non-existent patient 58 D APPADD(.ZZZ,3100123.09,3100123.093,8989898989,"Dr Office",30,"Sam's Note",1) 59 I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",! 60 ; Test for a non-existent resource name 61 D APPADD(.ZZZ,3100123.09,3100123.093,3,"lkajsflkjsadf",30,"Sam's Note",1) 62 I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",! 63 ; Test for corrupted resource 64 ; Can't test for -8 since it requires DB corruption 65 ; Test for inability to add appointment to BSDX Appointment 66 ; Also requires something wrong in the DB 67 ; Test for inability to add appointment to 2,44 68 ; Test by creating a duplicate appointment 69 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 70 D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1) 71 I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",! 72 ; Test for normality: 73 D APPADD(.ZZZ,3110123.09,3110123.093,3,"Dr Office",30,"Sam's Note",1) 74 ; Does Appt exist? 75 N APPID S APPID=+$P(^BSDXTMP($J,1),U) 76 I 'APPID W "Error Making Appt-1" QUIT 77 I +^BSDXAPPT(APPID,0)'=3110123.09 W "Error Making Appt-2" 78 I '$D(^DPT(3,"S",3110123.09)) W "Error Making Appt-3" 79 I '$D(^SC(2,"S",3110123.09)) W "Error Making Appt-4" 80 QUIT 81 ; 82 APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;EP 83 ; 84 ;Called by RPC: BSDX ADD NEW APPOINTMENT 85 ; 86 ;Add new appointment to 3 files 87 ; - BSDX APPOINTMENT 88 ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic 89 ; - Patient Appointment Subfile if Resource is linked to clinic 90 ; 91 ;Paramters: 92 ;BSDXY: Global Return (RPC must be set to Global Array) 93 ;BSDXSTART: FM Start Date 94 ;BSDXEND: FM End Date 95 ;BSDXPATID: Patient DFN 96 ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN) 97 ;BSDXLEN is the appointment duration in minutes 98 ;BSDXNOTE is the Appiontment Note 99 ;BSDXATID is used for 2 purposes: 100 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt. 101 ; if BSDXATID = a number, then it is the access type id (used for rebooking) 102 ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional) 103 ; 104 ;Return: 105 ; ADO.net Recordset having fields: 106 ; AppointmentID and ErrorNumber 107 ; 108 ;Test lines: 109 ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN 110 ; 111 ; Deal with optional arguments 112 S BSDXRADEXAM=$G(BSDXRADEXAM) 113 ; Return Array; set Return and clear array 114 S BSDXY=$NA(^BSDXTMP($J)) 115 K ^BSDXTMP($J) 116 ; $ET 117 N $ET S $ET="G ETRAP^BSDX07" 118 ; Counter 119 N BSDXI S BSDXI=0 120 ; Lock BSDX node, only to synchronize access to the globals. 121 ; It's not expected that the error will ever happen as no filing 122 ; is supposed to take 5 seconds. 123 L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q 124 ; Header Node 125 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30) 126 ;Restartable Transaction; restore paramters when starting. 127 ; (Params restored are what's passed here + BSDXI) 128 TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07" 129 ; 130 ; Turn off SDAM APPT PROTOCOL BSDX Entries 131 N BSDXNOEV 132 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol 133 ; 134 ; Set Error Message to be empty 135 N BSDXERR S BSDXERR=0 136 ; 137 ;;;test for error inside transaction. See if %ZTER works 138 I $G(bsdxdie) S X=1/0 139 ;;;test 140 ;;;test for TRESTART 141 I $G(bsdxrestart) K bsdxrestart TRESTART 142 ;;;test 143 ; 144 ; -- Start and End Date Processing -- 145 ; If C# sends the dates with extra zeros, remove them 146 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND 147 ; Are the dates valid? Must be FM Dates > than 2010 148 I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q 149 I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q 150 ; 151 ;; If Ending date doesn't have a time, this is an error --rm 1.5 152 ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q 153 ; 154 ; If the Start Date is greater than the end date, swap dates 155 N BSDXTMP 156 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP 157 ; 158 ; Check if the patient exists: 159 ; - DFN valid number? 160 ; - Valid Patient in file 2? 161 I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q 162 I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q 163 ; 164 ;Validate Resource entry 165 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q 166 N BSDXRESD ; Resource IEN 167 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0)) 168 N BSDXRNOD ; Resouce zero node 169 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0)) 170 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q 171 ; 172 ; Walk-in (Unscheduled) Appointment? 173 N BSDXWKIN S BSDXWKIN=0 174 I BSDXATID="WALKIN" S BSDXWKIN=1 175 ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number 176 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID="" 177 ; 178 ; Done with all checks, let's make appointment in BSDX APPOINTMENT 179 N BSDXAPPTID 180 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) 181 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q 182 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) 183 ; 184 ; Then Create Subfiles in 2/44 Appointment 185 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN 186 ; Only if we have a valid Hosp Loc can we make an appointment 187 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR) Q 188 . N BSDXC 189 . S BSDXC("PAT")=BSDXPATID 190 . S BSDXC("CLN")=BSDXSCD 191 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins 192 . S:BSDXWKIN BSDXC("TYP")=4 193 . S BSDXC("ADT")=BSDXSTART 194 . S BSDXC("LEN")=BSDXLEN 195 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field 196 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI 197 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note 198 . S BSDXC("USR")=DUZ 199 . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC) 200 . Q:BSDXERR 201 . ;Update RPMS Clinic availability 202 . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) 203 . Q 204 ; 205 ;Return Recordset 206 TCOMMIT 207 L -^BSDXAPPT(BSDXPATID) 208 S BSDXI=BSDXI+1 209 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30) 210 S BSDXI=BSDXI+1 211 S ^BSDXTMP($J,BSDXI)=$C(31) 212 Q 213 BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN 214 N DA,DIK 215 S DIK="^BSDXAPPT(",DA=BSDXAPPTID 216 D ^DIK 217 Q 218 ; 30 ;Entry point for debugging 31 ; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)") 32 Q 33 ; 34 APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;Private EP 35 ; 36 ;Called by RPC: BSDX ADD NEW APPOINTMENT 37 ; 38 ;Add new appointment to 3 files 39 ; - BSDX APPOINTMENT 40 ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic 41 ; - Patient Appointment Subfile if Resource is linked to clinic 42 ; 43 ;Paramters: 44 ;BSDXY: Global Return (RPC must be set to Global Array) 45 ;BSDXSTART: FM Start Date 46 ;BSDXEND: FM End Date 47 ;BSDXPATID: Patient DFN 48 ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN) 49 ;BSDXLEN is the appointment duration in minutes 50 ;BSDXNOTE is the Appiontment Note 51 ;BSDXATID is used for 2 purposes: 52 ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt. 53 ; if BSDXATID = a number, then it is the access type id (used for rebooking) 54 ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional) 55 ; 56 ;Return: 57 ; ADO.net Recordset having fields: 58 ; AppointmentID and ErrorNumber 59 ; 60 ; TODO: Specifying BSDXLEN and BSDXEND is redundant. For future programmers 61 ; to sort out. Needs changes on client. 62 ; 63 ;Test lines: 64 ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN 65 ; 66 ; Deal with optional arguments 67 S BSDXRADEXAM=$G(BSDXRADEXAM) 68 ; 69 ; Return Array; set Return and clear array 70 S BSDXY=$NA(^BSDXTMP($J)) 71 K ^BSDXTMP($J) 72 ; 73 ; $ET 74 N $ET S $ET="G ETRAP^BSDX07" 75 ; 76 ; Counter 77 N BSDXI S BSDXI=0 78 ; 79 ; Lock BSDX node, only to synchronize access to the globals. 80 ; It's not expected that the error will ever happen as no filing 81 ; is supposed to take 5 seconds. 82 L +^BSDXPAT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q 83 ; 84 ; Header Node 85 S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30) 86 ; 87 ; Turn off SDAM APPT PROTOCOL BSDX Entries 88 N BSDXNOEV 89 S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol 90 ; 91 ; Set Error Message to be empty 92 N BSDXERR S BSDXERR=0 93 ; 94 ;;;test for error. See if %ZTER works 95 I $G(BSDXDIE) N X S X=1/0 96 ;;;test 97 ; 98 ; -- Start and End Date Processing -- 99 ; If C# sends the dates with extra zeros, remove them 100 S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND 101 ; Are the dates valid? Must be FM Dates > than 2010 102 I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q 103 I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q 104 ; 105 ;; If Ending date doesn't have a time, this is an error --rm 1.5 106 ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q 107 ; 108 ; If the Start Date is greater than the end date, swap dates 109 N BSDXTMP 110 I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP 111 ; 112 ; Check if the patient exists: 113 ; - DFN valid number? 114 ; - Valid Patient in file 2? 115 I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q 116 I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q 117 ; 118 ;Validate Resource entry 119 I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q 120 N BSDXRESD ; Resource IEN 121 S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0)) 122 N BSDXRNOD ; Resouce zero node 123 S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0)) 124 I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q 125 ; 126 ; Walk-in (Unscheduled) Appointment? 127 N BSDXWKIN S BSDXWKIN=0 128 I BSDXATID="WALKIN" S BSDXWKIN=1 129 ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number 130 I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID="" 131 ; 132 ; Now, check if PIMS has any issues with us making the appt using MAKECK 133 N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN 134 N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK 135 N BSDXC ; Array to send to MAKE and MAKECK APIs 136 ; Only if we have a valid Hosp Location 137 I +BSDXSCD,$D(^SC(BSDXSCD,0)) D 138 . S BSDXC("PAT")=BSDXPATID 139 . S BSDXC("CLN")=BSDXSCD 140 . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins 141 . S:BSDXWKIN BSDXC("TYP")=4 142 . S BSDXC("ADT")=BSDXSTART 143 . S BSDXC("LEN")=BSDXLEN 144 . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field 145 . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI 146 . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note 147 . S BSDXC("USR")=DUZ 148 . S BSDXERR=$$MAKECK^BSDXAPI(.BSDXC) 149 I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKECK^BSDXAPI returned error code: "_BSDXERR) Q ; no need for roll back 150 ; 151 ; Done with all checks, let's make appointment in BSDX APPOINTMENT 152 N BSDXAPPTID 153 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) 154 I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q ; no roll back needed! No appts made. 155 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) ; no error checks are made here 156 ; I don't think it's important b/c users can detect right away if the WP 157 ; filing fails. 158 ; 159 I $G(BSDXSIMERR1) D ERR(BSDXI,"-11~BSDX07 Error: Simulated Error"),ROLLBACK(BSDXAPPTID,.BSDXC) Q ; UT Line 160 ; 161 ; Only if we have a valid Hosp Loc can we make an appointment in 2/44 162 ; Use BSDXC array from before. 163 ; FYI: $$MAKE itself calls $$MAKECK to check again for being okay. 164 ; If an error happens here, we roll back both ^BSDXAPPT and 2/44 by deleting 165 N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK 166 I +BSDXSCD,$D(^SC(BSDXSCD,0)) S BSDXERR=$$MAKE^BSDXAPI(.BSDXC) 167 I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR),ROLLBACK(BSDXAPPTID,.BSDXC) Q 168 ; 169 ; Unlock 170 L -^BSDXPAT(BSDXPATID) 171 ; 172 ;Return Recordset 173 S BSDXI=BSDXI+1 174 S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30) 175 S BSDXI=BSDXI+1 176 S ^BSDXTMP($J,BSDXI)=$C(31) 177 Q 219 178 STRIP(BSDXZ) ;Replace control characters with spaces 220 221 222 223 179 N BSDXI 180 F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999) 181 Q BSDXZ 182 ; 224 183 BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) ;ADD BSDX APPOINTMENT ENTRY 225 226 227 N BSDXAPPTID228 229 230 231 232 233 234 235 236 S BSDXFDA(9002018.4,"+1,",.14)=BSDXRADEXAM237 238 239 240 241 184 ;Returns ien in BSDXAPPT or 0 if failed 185 ;Create entry in BSDX APPOINTMENT 186 N BSDXAPPTID,BSDXFDA 187 S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART 188 S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND 189 S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID 190 S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD 191 S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ) 192 S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT 193 S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y" 194 S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID 195 S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM) 196 N BSDXIEN,BSDXMSG 197 D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG") 198 S BSDXAPPTID=+$G(BSDXIEN(1)) 199 Q BSDXAPPTID 200 ; 242 201 BSDXWP(BSDXAPPTID,BSDXNOTE) ; 243 ;Add WP field 244 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" 245 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0) 246 I $D(BSDXNOTE(.5)) D 247 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG") 248 Q 249 ; 202 ;Add WP field 203 N BSDXMSG 204 I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" 205 I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0) 206 I $D(BSDXNOTE(.5)) D 207 . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG") 208 Q 209 ; 250 210 ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP 251 252 253 254 255 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 211 ;Called by BSDX ADD APPOINTMENT protocol 212 ;BSDXSC=IEN of clinic in ^SC 213 ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note 214 ; 215 N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES,BSDXNOTE,BSDXEND 216 Q:+$G(BSDXNOEV) 217 I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) 218 E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) 219 Q:'+$G(BSDXRES) 220 S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0)) 221 Q:BSDXNOD="" 222 S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0)) 223 S BSDXWKIN="" 224 S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile 225 S BSDXLEN=$P(BSDXNOD,U,2) 226 Q:'+BSDXLEN 227 S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0) 228 S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN) 229 Q:'+BSDXAPPTID 230 S BSDXNOTE=$P(BSDXNOD,U,4) 231 I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) 232 D ADDEVT3(BSDXRES) 233 Q 234 ; 275 235 ADDEVT3(BSDXRES) ; 276 ;Call RaiseEvent to notify GUI clients 277 N BSDXRESN 278 S BSDXRESN=$G(^BSDXRES(BSDXRES,0)) 279 Q:BSDXRESN="" 280 S BSDXRESN=$P(BSDXRESN,"^") 281 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","") 282 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN) 283 Q 284 ; 285 ERR(BSDXI,BSDXERR) ;Error processing 286 S BSDXI=BSDXI+1 287 S BSDXERR=$TR(BSDXERR,"^","~") 288 I $TL>0 TROLLBACK 289 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30) 290 S BSDXI=BSDXI+1 291 S ^BSDXTMP($J,BSDXI)=$C(31) 292 L -^BSDXAPPT(BSDXPATID) 293 Q 294 ; 236 ;Call RaiseEvent to notify GUI clients 237 N BSDXRESN 238 S BSDXRESN=$G(^BSDXRES(BSDXRES,0)) 239 Q:BSDXRESN="" 240 S BSDXRESN=$P(BSDXRESN,"^") 241 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","") 242 D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN) 243 Q 244 ; 245 ROLLBACK(BSDXAPPTID,BSDXC) ; Private EP; Roll back appointment set 246 ; DO NOT USE except as an emergency measure - only if unforseen error occurs 247 ; Input: 248 ; Appointment ID to remove from ^BSDXAPPT 249 ; BSDXC array (see array format in $$MAKE^BSDXAPI) 250 N % 251 D BSDXDEL^BSDX07(BSDXAPPTID) 252 S:$D(BSDXC) %=$$UNMAKE^BSDXAPI(.BSDXC) ; rtn value always 0 253 QUIT 254 ; 255 BSDXDEL(BSDXAPPTID) ;Private EP ; Deletes appointment BSDXAPPTID from ^BSDXAPPT 256 ; DO NOT USE except in emergencies to roll back an appointment set 257 N DA,DIK 258 S DIK="^BSDXAPPT(",DA=BSDXAPPTID 259 D ^DIK 260 Q 261 ; 262 ERR(BSDXI,BSDXERR) ;Error processing - different from error trap. 263 ; Unlock first 264 L -^BSDXPAT(BSDXPATID) 265 ; If last line is $C(31), we are done. No more errors to send to client. 266 I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT 267 S BSDXI=BSDXI+1 268 S BSDXERR=$TR(BSDXERR,"^","~") 269 S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30) 270 S BSDXI=BSDXI+1 271 S ^BSDXTMP($J,BSDXI)=$C(31) 272 Q 273 ; 295 274 ETRAP ;EP Error trap entry 296 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 297 ; Rollback, otherwise ^XTER will be empty from future rollback 298 I $TL>0 TROLLBACK 299 D ^%ZTER 300 S $EC="" ; Clear Error 301 ; Log error message and send to client 302 I '$D(BSDXI) N BSDXI S BSDXI=0 303 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE)) 304 Q 305 ; 306 DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR 307 ; 308 DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y) 309 F %=%:-1:281 S Y=%#4=1+1+Y 310 S Y=$E(X,6,7)+Y#7 311 Q 312 ; 313 AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability 314 ;SEE SDM1 315 N Y,DFN 316 N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG 317 N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I 318 S Y=BSDXSCD,DFN=BSDXPATID 319 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 320 ;Determine maximum days for scheduling 321 S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365 322 S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1)) 323 S SDDATE=BSDXSTART 324 S SDSDATE=SDDATE,SDDATE=SDDATE\1 325 1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC 326 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC 327 S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2) 328 S X2=SDEDT D C^%DTC S SDEDT=X 329 S Y=BSDXSTART 330 EN1 S (X,SD)=Y,SM=0 D DOW 331 S 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,".") 332 S S=BSDXLEN 333 ;Check if BSDXLEN evenly divisible by appointment length 334 S RPMSL=$P(SL,U) 335 I BSDXLEN<RPMSL S BSDXLEN=RPMSL 336 I BSDXLEN#RPMSL'=0 D 337 . S BSDXINC=BSDXLEN\RPMSL 338 . S BSDXINC=BSDXINC+1 339 . S BSDXLEN=RPMSL*BSDXINC 340 S SL=S_U_$P(SL,U,2,99) 341 SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9 342 L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC 343 S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1) 344 S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST 345 I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q 346 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 347 ; 348 SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP 349 S SDNOT=1 350 S ABORT=0 351 F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT 352 . S ST=$E(S,I+1) S:ST="" ST=" " 353 . S Y=$E(STR,$F(STR,ST)-2) 354 . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q 355 . I Y="" S ABORT=1 Q 356 . 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 357 . Q 358 S ^SC(SC,"ST",$P(SD,"."),1)=S 359 L -^SC(SC,"ST",$P(SD,"."),1) 360 Q 275 N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap 276 D ^%ZTER 277 ; 278 I +$G(BSDXAPPTID) D ROLLBACK(BSDXAPPTID,.BSDXC) ; Rollback if BSDXAPPTID exists 279 ; 280 ; Log error message and send to client 281 I '$D(BSDXI) N BSDXI S BSDXI=0 282 D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE)) 283 Q:$Q 1_U_"Mumps Error" Q 284 ;
Note:
See TracChangeset
for help on using the changeset viewer.
