iSharkFly-Open
/
VistA-Scheduling
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

updated the BSDX version to 1.7 ,, 

- fix "BSDX01.m" routine , it was take too long time to retrieve patient radiology exams.
This commit is contained in:
tariq 2012-10-08 10:59:10 +00:00
parent fbdc25600b
commit 3e60d492b4
41 changed files with 1350 additions and 1254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
m/BSDX01.m
View File

@ -1,5 +1,5 @@
BSDX01 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:52am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX01 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:46pm
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
SUINFOD(BSDXY,BSDXDUZ) ;EP Debugging entry point
@ -291,11 +291,12 @@ INDIV(BSDXSC) ; PEP - Is ^SC clinic in the same DUZ(2) as user?
I DIV="" Q 1 ; If clinic has no division, consider it avial to user.
I DIV=DUZ(2) Q 1 ; If same, then User is in same Div as Clinic
E Q 0 ; Otherwise, no
QUIT
INDIV2(BSDXRES) ; PEP - Is Resource in the same DUZ(2) as user?
; Input BSDXRES - BSDX RESOURCE IEN
; Output: True of False
Q $$INDIV($P($G(^BSDXRES(BSDXRES,0)),U,4)) ; Extract Hospital Location and send to $$INDIV
UTINDIV ; Unit Test $$INDIV
UnitTestINDIV
W "Testing if they are the same",!
S DUZ(2)=67
I '$$INDIV(1) W "ERROR",!
@ -309,7 +310,7 @@ UTINDIV ; Unit Test $$INDIV
I $$INDIV(1) W "ERROR",!
I $$INDIV(2) W "ERROR",!
QUIT
UTINDIV2 ; Unit Test $$INDIV2
UnitTestINDIV2
W "Testing if they are the same",!
S DUZ(2)=69
I $$INDIV2(22)'=0 W "ERROR",!
@ -344,7 +345,13 @@ GETRADEX(BSDXY,DFN,SCIEN) ; Get All Pending and On Hold Radiology Exams for Pati
; File 75.1 = RAD/NUC MED ORDERS
; Fields 5 = Request Status; 2 = Procedure; 16 = Requested Entered Date Time
; Filter Field: First piece is DFN, 5th piece is 3 or 5 (Status of Pending Or Hold); 20th piece is Radiology Location requested
D LIST^DIC(75.1,"","@;5;2;16","P","","","","B","I $P(^(0),U)=DFN&(35[$P(^(0),U,5))&($P(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
;
;;EHS/MKH,BAH;;UJO*1.0*143;;30/09/2012;; Update [Fix the performance issue in SchedGUI]
; START OF CODE CHANGES FOR [UJO*1.0*143]
; Commented old Line
;D LIST^DIC(75.1,"","@;5;2;16","P","","","","B","I $P(^(0),U)=DFN&(35[$P(^(0),U,5))&($P(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
DO FIND^DIC(75.1,"","@;5;2;16","QP",DFN,"","B","IF 35[$PIECE(^(0),U,5)&($PIECE(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
; END OF CODE CHANGES FOR [UJO*1.0*143]
;
IF $DATA(BSDXERR) GOTO END
;

7
m/BSDX02.m
View File

@ -1,5 +1,5 @@
BSDX02 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 11:09am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX02 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:47pm
;;1.6;BSDX;;Aug 31, 2011;Build 25
;Licensed under LGPL
; Change Log
; July 15 2010: UJO/SMH - Pass FM dates in instead of US dates for i18n
@ -29,8 +29,7 @@ CRSCH(BSDXY,BSDXRES,BSDXSTART,BSDXEND,BSDXWKIN) ;
K ^BSDXTMP($J)
S BSDXERR=""
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^T00030PATIENTNAME^T00030RESOURCENAME"
S ^(0)=^(0)_"^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE^T00006SEX^T00040PID^D00030DOB^I00020RADIOLOGY_EXAM"_$C(30)
S ^BSDXTMP($J,0)="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^T00030PATIENTNAME^T00030RESOURCENAME^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE^T00006SEX^T00040PID^D00030DOB^I00020RADIOLOGY_EXAM"_$C(30)
D ^XBKVAR S X="ETRAP^BSDX02",@^%ZOSF("TRAP")
;
; S %DT="T",X=BSDXSTART D ^%DT S BSDXSTART=Y

2
m/BSDX03.m
View File

@ -1,5 +1,5 @@
BSDX03 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:14am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
;Licensed under LGPL
;
;

4
m/BSDX04.m
View File

@ -1,5 +1,5 @@
BSDX04 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 7/6/12 10:55am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX04 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 4/28/11 10:15am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Change Log:
; July 11 2010: Pass BSDXSTART and END as FM dates rather than US formatted dates

2
m/BSDX05.m
View File

@ -1,5 +1,5 @@
BSDX05 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDX06.m
View File

@ -1,5 +1,5 @@
BSDX06 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Change Log:
; UJO/SMH: July 15 2010: Change in BSDXSTART and BSDXEND: get

228
m/BSDX07.m
View File

@ -1,17 +1,16 @@
BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:02pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:
; UJO/SMH
; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments
; thanks to Rick Marshall and Zach Gonzalez at Oroville.
; v1.42 Oct 30 2010 - Extensive refactoring.
; v1.5 Mar 15 2011 - End time does not have to have time anymore.
; It could be midnight of the next day
; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams...
; v1.7 Jun 20 2012 - Refactoring to remove transactions - many changes
; - AVUPDT moved to AVUPDTMK in BSDXAPI1
;
; Error Reference:
; -1: Patient Record is locked. This means something is wrong!!!!
@ -25,13 +24,62 @@ BSDX07 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:02pm
; -9: Couldn't add appointment to BSDX APPOINTMENT
; -10: Couldn't add appointment to files 2 and/or 44
; -100: Mumps Error
;
APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID) ;EP
;Entry point for debugging
; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
Q
;
APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;Private EP
UT ; Unit Tests
N ZZZ
; Test for bad start date
D APPADD(.ZZZ,2100123,3100123.3,2,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",!
; Test for bad end date
D APPADD(.ZZZ,3100123,2100123.3,2,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",!
; Test for end date without time
D APPADD(.ZZZ,3100123.1,3100123,2,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",!
; Test for mumps error
S bsdxdie=1
D APPADD(.ZZZ,3100123.09,3100123.093,2,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",!
K bsdxdie
; Test for TRESTART
s bsdxrestart=1
D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
k bsdxrestart
; Test for non-numeric patient
D APPADD(.ZZZ,3100123.09,3100123.093,"CAT,DOG","Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",!
; Test for a non-existent patient
D APPADD(.ZZZ,3100123.09,3100123.093,8989898989,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",!
; Test for a non-existent resource name
D APPADD(.ZZZ,3100123.09,3100123.093,3,"lkajsflkjsadf",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",!
; Test for corrupted resource
; Can't test for -8 since it requires DB corruption
; Test for inability to add appointment to BSDX Appointment
; Also requires something wrong in the DB
; Test for inability to add appointment to 2,44
; Test by creating a duplicate appointment
D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",!
; Test for normality:
D APPADD(.ZZZ,3110123.09,3110123.093,3,"Dr Office",30,"Sam's Note",1)
; Does Appt exist?
N APPID S APPID=+$P(^BSDXTMP($J,1),U)
I 'APPID W "Error Making Appt-1" QUIT
I +^BSDXAPPT(APPID,0)'=3110123.09 W "Error Making Appt-2"
I '$D(^DPT(3,"S",3110123.09)) W "Error Making Appt-3"
I '$D(^SC(2,"S",3110123.09)) W "Error Making Appt-4"
QUIT
;
APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;EP
;
;Called by RPC: BSDX ADD NEW APPOINTMENT
;
@ -57,32 +105,27 @@ APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXR
; ADO.net Recordset having fields:
; AppointmentID and ErrorNumber
;
; TODO: Specifying BSDXLEN and BSDXEND is redundant. For future programmers
; to sort out. Needs changes on client.
;
;Test lines:
;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
;
; Deal with optional arguments
S BSDXRADEXAM=$G(BSDXRADEXAM)
;
; Return Array; set Return and clear array
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
;
; $ET
N $ET S $ET="G ETRAP^BSDX07"
;
; Counter
N BSDXI S BSDXI=0
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXPAT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
;
L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
; Header Node
S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
;Restartable Transaction; restore paramters when starting.
; (Params restored are what's passed here + BSDXI)
TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07"
;
; Turn off SDAM APPT PROTOCOL BSDX Entries
N BSDXNOEV
@ -91,8 +134,11 @@ APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXR
; Set Error Message to be empty
N BSDXERR S BSDXERR=0
;
;;;test for error. See if %ZTER works
I $G(BSDXDIE) N X S X=1/0
;;;test for error inside transaction. See if %ZTER works
I $G(bsdxdie) S X=1/0
;;;test
;;;test for TRESTART
I $G(bsdxrestart) K bsdxrestart TRESTART
;;;test
;
; -- Start and End Date Processing --
@ -129,12 +175,17 @@ APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXR
; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
;
; Now, check if PIMS has any issues with us making the appt using MAKECK
; Done with all checks, let's make appointment in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
;
; Then Create Subfiles in 2/44 Appointment
N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4) ; Hosp Location IEN
N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK
N BSDXC ; Array to send to MAKE and MAKECK APIs
; Only if we have a valid Hosp Location
I +BSDXSCD,$D(^SC(BSDXSCD,0)) D
; Only if we have a valid Hosp Loc can we make an appointment
I +BSDXSCD,$D(^SC(BSDXSCD,0)) D I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR) Q
. N BSDXC
. S BSDXC("PAT")=BSDXPATID
. S BSDXC("CLN")=BSDXSCD
. S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
@ -145,36 +196,26 @@ APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXR
. S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
. S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
. S BSDXC("USR")=DUZ
. S BSDXERR=$$MAKECK^BSDXAPI(.BSDXC)
I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKECK^BSDXAPI returned error code: "_BSDXERR) Q ; no need for roll back
;
; Done with all checks, let's make appointment in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q ; no roll back needed! No appts made.
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) ; no error checks are made here
; I don't think it's important b/c users can detect right away if the WP
; filing fails.
;
I $G(BSDXSIMERR1) D ERR(BSDXI,"-11~BSDX07 Error: Simulated Error"),ROLLBACK(BSDXAPPTID,.BSDXC) Q ; UT Line
;
; Only if we have a valid Hosp Loc can we make an appointment in 2/44
; Use BSDXC array from before.
; FYI: $$MAKE itself calls $$MAKECK to check again for being okay.
; If an error happens here, we roll back both ^BSDXAPPT and 2/44 by deleting
N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK
I +BSDXSCD,$D(^SC(BSDXSCD,0)) S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR),ROLLBACK(BSDXAPPTID,.BSDXC) Q
;
; Unlock
L -^BSDXPAT(BSDXPATID)
. S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
. Q:BSDXERR
. ;Update RPMS Clinic availability
. D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
. Q
;
;Return Recordset
TCOMMIT
L -^BSDXAPPT(BSDXPATID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
BSDXDEL(BSDXAPPTID) ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
N DA,DIK
S DIK="^BSDXAPPT(",DA=BSDXAPPTID
D ^DIK
Q
;
STRIP(BSDXZ) ;Replace control characters with spaces
N BSDXI
F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
@ -183,7 +224,7 @@ STRIP(BSDXZ) ;Replace control characters with spaces
BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) ;ADD BSDX APPOINTMENT ENTRY
;Returns ien in BSDXAPPT or 0 if failed
;Create entry in BSDX APPOINTMENT
N BSDXAPPTID,BSDXFDA
N BSDXAPPTID
S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
@ -192,7 +233,7 @@ BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) ;ADD BSDX AP
S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM)
S BSDXFDA(9002018.4,"+1,",.14)=BSDXRADEXAM
N BSDXIEN,BSDXMSG
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXAPPTID=+$G(BSDXIEN(1))
@ -200,7 +241,6 @@ BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM) ;ADD BSDX AP
;
BSDXWP(BSDXAPPTID,BSDXNOTE) ;
;Add WP field
N BSDXMSG
I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
I $D(BSDXNOTE(.5)) D
@ -212,7 +252,7 @@ ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
;BSDXSC=IEN of clinic in ^SC
;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
;
N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES,BSDXNOTE,BSDXEND
N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
Q:+$G(BSDXNOEV)
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
E I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
@ -242,43 +282,79 @@ ADDEVT3(BSDXRES) ;
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
ROLLBACK(BSDXAPPTID,BSDXC) ; Private EP; Roll back appointment set
; DO NOT USE except as an emergency measure - only if unforseen error occurs
; Input:
; Appointment ID to remove from ^BSDXAPPT
; BSDXC array (see array format in $$MAKE^BSDXAPI)
N %
D BSDXDEL^BSDX07(BSDXAPPTID)
S:$D(BSDXC) %=$$UNMAKE^BSDXAPI(.BSDXC) ; rtn value always 0
QUIT
;
BSDXDEL(BSDXAPPTID) ;Private EP ; Deletes appointment BSDXAPPTID from ^BSDXAPPT
; DO NOT USE except in emergencies to roll back an appointment set
N DA,DIK
S DIK="^BSDXAPPT(",DA=BSDXAPPTID
D ^DIK
Q
;
ERR(BSDXI,BSDXERR) ;Error processing - different from error trap.
; Unlock first
L -^BSDXPAT(BSDXPATID)
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
ERR(BSDXI,BSDXERR) ;Error processing
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
I $TL>0 TROLLBACK
S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
L -^BSDXAPPT(BSDXPATID)
Q
;
ETRAP ;EP Error trap entry
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
; Rollback, otherwise ^XTER will be empty from future rollback
I $TL>0 TROLLBACK
D ^%ZTER
;
I +$G(BSDXAPPTID) D ROLLBACK(BSDXAPPTID,.BSDXC) ; Rollback if BSDXAPPTID exists
;
S $EC="" ; Clear Error
; Log error message and send to client
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
Q:$Q 1_U_"Mumps Error" Q
Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
F %=%:-1:281 S Y=%#4=1+1+Y
S Y=$E(X,6,7)+Y#7
Q
;
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
;SEE SDM1
N Y,DFN
N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
S Y=BSDXSCD,DFN=BSDXPATID
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
;Determine maximum days for scheduling
S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
S SDDATE=BSDXSTART
S SDSDATE=SDDATE,SDDATE=SDDATE\1
1 ;L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
S X2=SDEDT D C^%DTC S SDEDT=X
S Y=BSDXSTART
EN1 S (X,SD)=Y,SM=0 D DOW
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,".")
S S=BSDXLEN
;Check if BSDXLEN evenly divisible by appointment length
S RPMSL=$P(SL,U)
I BSDXLEN<RPMSL S BSDXLEN=RPMSL
I BSDXLEN#RPMSL'=0 D
. S BSDXINC=BSDXLEN\RPMSL
. S BSDXINC=BSDXINC+1
. S BSDXLEN=RPMSL*BSDXINC
S SL=S_U_$P(SL,U,2,99)
SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
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
;
SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
S SDNOT=1
S ABORT=0
F I=ST+ST:SDDIF:SS-SDDIF D Q:ABORT
. S ST=$E(S,I+1) S:ST="" ST=" "
. S Y=$E(STR,$F(STR,ST)-2)
. I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
. I Y="" S ABORT=1 Q
. 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
. Q
S ^SC(SC,"ST",$P(SD,"."),1)=S
L -^SC(SC,"ST",$P(SD,"."),1)
Q

278
m/BSDX08.m
View File

@ -1,22 +1,24 @@
BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:22pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am
;;1.6;BSDX;;Aug 31, 2011;Build 25
;
; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
;
; Change History
; 3101022 UJO/SMH v1.42
; - Transaction work. As of v 1.7, all work here has been superceded
; - Refactoring of AVUPDT - never tested though.
; - Transaction now restartable. Thanks to
; --> Zach Gonzalez and Rick Marshall for fix.
; - Extra TROLLBACK in Lock Statement when lock fails.
; --> Removed--Rollback is already in ERR tag.
; - Added new statements to old SD code in AVUPDT to obviate
; --> need to restore variables in transaction
; - Refactored this chunk of code. Don't really know whether it
; --> worked in the first place. Waiting for bug report to know.
; - Refactored all of APPDEL.
;
; 3111125 UJO/SMH v1.5
; - Added ability to remove checked in appointments. Added a couple
; of units tests for that under UT2.
;
; 3120625 VEN/SMH v1.7
; - Transactions removed. Code refactored to work w/o txns.
; - Moved AVUPDT to AVUPDTCN in BSDXAPI1. BSDXAPI takes care of calling
; that.
; - Minor reformatting because of how KIDS adds tabs.
;
; Error Reference:
; -1~BSDX08: Appt record is locked. Please contact technical support.
@ -28,15 +30,76 @@ BSDX08 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:22pm
; -7~BSDX08: Patient does not have an appointment in PIMS Clinic
; -8^BSDX08: Unable to find associated PIMS appointment for this patient
; -9^BSDX08: BSDXAPI returned an error: (error)
; -10^BSDX08: $$BSDXCAN failed (Fileman filing error)
; -100~BSDX08 Error: (Mumps Error)
;
APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
;Entry point for debugging
;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
Q
;
APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ; Private EP
UT ; Unit Tests
; Test 1: Make normal appointment and cancel it. See if every thing works
N ZZZ
D APPADD^BSDX07(.ZZZ,3110123.2,3110123.3,4,"Dr Office",10,"Sam's Note",1)
S APPID=+$P(^BSDXTMP($J,1),U)
D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
I $P(^BSDXAPPT(APPID,0),U,12)'>0 W "Error in Cancellation-1"
I $O(^SC(2,"S",3110123.2,1,0))]"" W "Error in Cancellation-2"
I $P(^DPT(4,"S",3110123.2,0),U,2)'="PC" W "Error in Cancellation-3"
I ^DPT(4,"S",3110123.2,"R")'="Sam's Cancel Note" W "Error in Cancellation-4"
;
; Test 2: Check for -1
; Make appt
D APPADD^BSDX07(.ZZZ,3110125.2,3110125.3,4,"Dr Office",10,"Sam's Note",1)
; Lock the node in another job
S APPID=+$P(^BSDXTMP($J,1),U)
; W "Lock ^BSDXAPPT("_APPID_") in another session. You have 10 seconds." H 10
D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
;
; Test 3: Check for -100
S bsdxdie=1
D APPADD^BSDX07(.ZZZ,3110126.2,3110126.3,4,"Dr Office",10,"Sam's Note",1)
S APPID=+$P(^BSDXTMP($J,1),U)
D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
I $P(^BSDXTMP($J,1),"~")'=-100 W "Error in -100",!
K bsdxdie
;
; Test 4: Restartable transaction
S bsdxrestart=1
D APPADD^BSDX07(.ZZZ,3110128.2,3110128.3,4,"Dr Office",10,"Sam's Note",1)
S APPID=+$P(^BSDXTMP($J,1),U)
D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
I $P(^DPT(4,"S",3110128.2,0),U,2)'="PC" W "Error in Restartable Transaction",!
;
; Test 5: for invalid Appointment ID (-2 and -3)
D APPDEL^BSDX08(.ZZZ,0,"PC",1,"Reasons")
I $P(^BSDXTMP($J,1),"~")'=-2 W "Error in -2",!
D APPDEL^BSDX08(.ZZZ,999999,"PC",1,"Reasons")
I $P(^BSDXTMP($J,1),"~")'=-3 W "Error in -3",!
UT2 ; More unit Tests
;
; Test 6: for Cancelling walkin and checked-in appointments
S BSDXSTART=$E($$NOW^XLFDT,1,12),BSDXEND=BSDXSTART+.0001
D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
S APPID=+$P(^BSDXTMP($J,1),U)
I APPID=0 W "Error in test 6",!
D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; check-in
D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; Delete appt
I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
;
; Test 7: for cancelling walkin and checked-in appointments
S BSDXSTART=$E($$NOW^XLFDT,1,12)+.0001,BSDXEND=BSDXSTART+.0001
D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
S APPID=+$P(^BSDXTMP($J,1),U)
I APPID=0 W "Error in test 6",!
D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; Checkin
S BSDXRES=$O(^BSDXRES("B","Dr Office",""))
S BSDXCLN=$P(^BSDXRES(BSDXRES,0),U,4)
S BSDXRESULT=$$RMCI^BSDXAPI(4,BSDXCLN,BSDXSTART) ; remove checkin
D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; delete appt
I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
QUIT
APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
;Called by RPC: BSDX CANCEL APPOINTMENT
;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
;Input Parameters:
@ -60,78 +123,70 @@ APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ; Private EP
;
; Counter
N BSDXI S BSDXI=0
;
; Header Node
S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
;
;Restartable Transaction; restore paramters when starting.
; (Params restored are what's passed here + BSDXI)
TSTART (BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT,BSDXI):T="BSDX CANCEL APPOINTEMENT^BSDX08"
;
; Turn off SDAM APPT PROTOCOL BSDX Entries
N BSDXNOEV
S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
;
;;;test for error inside transaction. See if %ZTER works
I $G(BSDXDIE1) N X S X=1/0
I $G(bsdxdie) S X=1/0
;;;test
;;;test for TRESTART
I $G(bsdxrestart) K bsdxrestart TRESTART
;;;test
;
; Check appointment ID and whether it exists
I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXAPPT(BSDXAPTID):5 E D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
;
; Start Processing:
; First, get data
; First, add cancellation date to appt entry in BSDX APPOINTMENT
N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
D BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT
;
; Check the resource ID and whether it exists
; Second, cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
; If the resource id doesn't exist...
; If the resouce id doesn't exist...
I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
;
;
; Check if PIMS will let us cancel the appointment using $$CANCELCK^BSDXAPI
; Get zero node of resouce
N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0)
S BSDXNOD=^BSDXRES(BSDXSC1,0)
; Get Hosp location
N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
; Error indicator
; Error indicator for Hosp Location filing for getting out of routine
N BSDXERR S BSDXERR=0
; Only file in 2/44 if there is an associated hospital location
I BSDXLOC D QUIT:BSDXERR
. I '$D(^SC(BSDXLOC,0)) S BSDXERR=1 D ERR(BSDXI,"-6~BSDX08: Invalid Hosp Location stored in Database") QUIT
. ; Get the IEN of the appointment in the "S" node of ^SC
. N BSDXSCIEN
. S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART)
. I BSDXSCIEN="" S BSDXERR=1 D ERR(BSDXI,"-7~BSDX08: Patient does not have an appointment in PIMS Clinic") QUIT
. ; Get the appointment node
. S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
. I BSDXNOD="" S BSDXERR=1 D ERR(BSDXI,"-8^BSDX08: Unable to find associated PIMS appointment for this patient") QUIT
. N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2)
. ; Cancel through BSDXAPI
. N BSDXZ
. D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART)
. I +BSDXZ>0 S BSDXERR=1 D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXZ,U,2)) QUIT
. ; Update Legacy PIMS clinic Availability
. D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
;
N BSDXC ; Array to pass to BSDXAPI
;
I BSDXLOC D
. S BSDXC("PAT")=BSDXPATID
. S BSDXC("CLN")=BSDXLOC
. S BSDXC("TYP")=BSDXTYP
. S BSDXC("ADT")=BSDXSTART
. S BSDXC("CDT")=$$NOW^XLFDT()
. S BSDXC("NOT")=BSDXNOT
. S:'+$G(BSDXCR) BSDXCR=11 ;Other
. S BSDXC("CR")=BSDXCR
. S BSDXC("USR")=DUZ
. ;
. S BSDXERR=$$CANCELCK^BSDXAPI(.BSDXC) ; 0 or 1^error message
; If error, quit. No need to rollback as no changes took place.
I BSDXERR D ERR(BSDXI,"-9~BSDX08: BSDXAPI reports that "_$P(BSDXERR,U,2)) QUIT
;
I $G(BSDXDIE2) N X S X=1/0
;
; Now cancel the appointment for real
; BSDXAPPT First; no need for rollback if error occured.
N BSDXERR S BSDXERR=$$BSDXCAN(BSDXAPTID) ; Add a cancellation date in BSDX APPOINTMENT
I BSDXERR D ERR(BSDXI,"-10~BSDX08: $$BSDXCAN failed (Fileman filing error): "_$P(BSDXERR,U,2)) QUIT
;
; Then PIMS:
; cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
; If error happens, must rollback ^BSDXAPPT
I BSDXLOC S BSDXERR=$$CANCEL^BSDXAPI(.BSDXC) ; Cancel through BSDXAPI
; Rollback BSDXAPPT if error occurs
I BSDXERR D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXERR,U,2)),ROLLBACK(BSDXAPTID) QUIT
;
TCOMMIT
L -^BSDXAPPT(BSDXAPTID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=""_$C(30)
@ -139,25 +194,80 @@ APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ; Private EP
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
BSDXCAN(BSDXAPTID) ; $$; Private; Cancel BSDX APPOINTMENT entry
; Input: Appt IEN in ^BSDXAPPT
; Output: 0 for success and 1^Msg for failure
N BSDXDATE,BSDXIENS,BSDXFDA,BSDXMSG
S BSDXDATE=$$NOW^XLFDT()
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update Legacy PIMS Clinic availability
;See SDCNP0
N SD,S ; Start Date
S (SD,S)=BSDXSTART
N I ; Clinic IEN in 44
S I=BSDXSCD
; if day has no schedule in legacy PIMS, forget about this update.
Q:'$D(^SC(I,"ST",SD\1,1))
N SL ; Clinic characteristics node (length of appt, when appts start etc)
S SL=^SC(I,"SL")
N X ; Hour Clinic Display Begins
S X=$P(SL,U,3)
N STARTDAY ; When does the day start?
S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
N SB ; ?? Who knows? Day Start - 1 divided by 100.
S SB=STARTDAY-1/100
S X=$P(SL,U,6) ; Now X is Display increments per hour
N HSI ; Slots per hour, try 1
S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
N SI ; Slots per hour, try 2
S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
N STR ; ??
S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
N SDDIF ; Slots per hour diff??
S SDDIF=$S(HSI<3:8/HSI,1:2)
S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
N Y ; Hours since start of Date
S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
N ST ; ??
; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
; Y\1 -> Hours since start of day; * SI: * slots
S ST=Y#1*SI\.6+(Y\1*SI)
N SS ; how many slots are supposed to be taken by appointment
S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
N I
I Y'<1 D ; If Hours since start of Date is greater than 1
. ; loop through pattern. Tired of documenting.
. F I=ST+ST:SDDIF D Q:Y="" Q:SS'>0
. . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""
. . S S=$E(S,1,I)_Y_$E(S,I+2,999)
. . S SS=SS-1
. . Q:SS'>0
S ^SC(BSDXSCD,"ST",SD\1,1)=S ; new pattern; global set
Q
;
APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD) ;
;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
;at time BSDXSD
N BSDXC,%H
S BSDXC("PAT")=BSDXPATID
S BSDXC("CLN")=BSDXLOC
S BSDXC("TYP")=BSDXTYP
S BSDXC("ADT")=BSDXSD
S %H=$H D YMD^%DTC
S BSDXC("CDT")=X+%
S BSDXC("NOT")=BSDXNOT
S:'+$G(BSDXCR) BSDXCR=11 ;Other
S BSDXC("CR")=BSDXCR
S BSDXC("USR")=DUZ
;
S BSDXZ=$$CANCEL^BSDXAPI(.BSDXC)
Q
;
BSDXCAN(BSDXAPTID) ;
;Cancel BSDX APPOINTMENT entry
N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")
S BSDXDATE=Y
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
K BSDXMSG
D FILE^DIE("","BSDXFDA","BSDXMSG")
I $D(BSDXMSG) Q 1_U_BSDXMSG("DIERR",1,"TEXT",1)
QUIT 0
;
ROLLBACK(BSDXAPTID) ; Proc; Private; Rollback cancellation
; Input same as $$BSDXCAN
N BSDXIENS S BSDXIENS=BSDXAPTID_","
N BSDXFDA S BSDXFDA(9002018.4,BSDXIENS,.12)="@"
N BSDXMSG
D FILE^DIE("","BSDXFDA","BSDXMSG")
;I $D(BSDXMSG) ; Not sure what to do. We are already handling an error.
QUIT
Q
;
CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
;when appointments cancelled via PIMS interface.
@ -181,10 +291,9 @@ CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
Q:'+BSDXRES BSDXFOUND
Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
. N BSDXNOD
. S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
. I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
I BSDXFOUND,+$G(BSDXAPPT) N % S %=$$BSDXCAN(BSDXAPPT) I % D ^%ZTER
I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
Q BSDXFOUND
;
CANEVT3(BSDXRES) ;
@ -199,30 +308,25 @@ CANEVT3(BSDXRES) ;
Q
;
ERR(BSDXI,BSDXERR) ;Error processing
; Unlock first
L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
I $TL>0 TROLLBACK
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
L -^BSDXAPPT(BSDXAPTID)
QUIT
;
ETRAP ;EP Error trap entry
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
; Rollback, otherwise ^XTER will be empty from future rollback
I $TL>0 TROLLBACK
D ^%ZTER
;
; Roll back BSDXAPPT;
; NB: What if a Mumps error happens inside fileman in BSDXAPI?
; I have decided the M errors are out of scope for me to handle.
D:$G(BSDXAPTID) ROLLBACK(BSDXAPTID)
;
S $EC="" ; Clear Error
; Log error message and send to client
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
Q:$Q 1_U_"-100~Mumps Error" Q
QUIT
;
;;;NB: This is code that is unused in both original and port.
; ; If not appt in the "S" node is found in ^SC then check associated RPMS Clinic Multiple

4
m/BSDX09.m
View File

@ -1,5 +1,5 @@
BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 6/21/12 11:03am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 4/28/11 10:18am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDX11.m
View File

@ -1,5 +1,5 @@
BSDX11 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
ENV0100 ;EP Version 1.0 Environment check

2
m/BSDX12.m
View File

@ -1,5 +1,5 @@
BSDX12 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDX13.m
View File

@ -1,5 +1,5 @@
BSDX13 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDX14.m
View File

@ -1,5 +1,5 @@
BSDX14 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX15.m
View File

@ -1,5 +1,5 @@
BSDX15 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX16.m
View File

@ -1,5 +1,5 @@
BSDX16 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 4/28/11 10:20am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX17.m
View File

@ -1,5 +1,5 @@
BSDX17 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX18.m
View File

@ -1,5 +1,5 @@
BSDX18 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX19.m
View File

@ -1,5 +1,5 @@
BSDX19 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX20.m
View File

@ -1,5 +1,5 @@
BSDX20 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX21.m
View File

@ -1,5 +1,5 @@
BSDX21 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX22.m
View File

@ -1,5 +1,5 @@
BSDX22 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX23.m
View File

@ -1,5 +1,5 @@
BSDX23 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

2
m/BSDX24.m
View File

@ -1,5 +1,5 @@
BSDX24 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

239
m/BSDX25.m
View File

@ -1,137 +1,118 @@
BSDX25 ; VEN/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 5:00pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX25 ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:
; 3110106: SMH -> Changed Check-in EP - Removed unused paramters. Will change C#
; 3120630: VEN/SMH -> Extensive Refactoring to remove transactions.
; -> Functionality still the same.
; -> Unit Tests in UT25^BSDXUT2
;
;
CHECKIND(BSDXY,BSDXAPPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP
UT ; Unit Tests
; Make appointment, checkin, then uncheckin
N ZZZ
N APPTTIME S APPTTIME=$E($$NOW^XLFDT(),1,12)
D APPADD^BSDX07(.ZZZ,APPTTIME,APPTTIME+.0001,3,"Dr Office",30,"Sam's Note",1)
N APPTID S APPTID=+^BSDXTMP($J,1)
N HL S HL=$$GET1^DIQ(9002018.4,APPTID,".07:.04","I")
D CHECKIN^BSDX25(.ZZZ,APPTID,$$NOW^XLFDT())
IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN CHECKIN 1",!
IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN CHECKIN 2",!
D RMCI^BSDX25(.ZZZ,APPTID)
IF $P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN UNCHECKIN 1",!
IF $G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN UNCHECKIN 2",!
D RMCI^BSDX25(.ZZZ,APPTID) ; again, test sanity in repeat
IF $P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN UNCHECKIN 1",!
IF $G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN UNCHECKIN 2",!
; now test various error conditions
; Test Error 1
D RMCI^BSDX25(.ZZZ,)
IF +^BSDXTMP($J,1)'=-1 WRITE "ERROR IN ETest 1",!
; Test Error 2
D RMCI^BSDX25(.ZZZ,234987234398)
IF +^BSDXTMP($J,1)'=-2 WRITE "ERROR IN Etest 2",!
; Tests for 3 to 5 difficult to produce
; Error tests follow: Mumps error test; Transaction restartability
N bsdxdie S bsdxdie=1
D RMCI^BSDX25(.ZZZ,APPTID)
IF +^BSDXTMP($J,1)'=-20 WRITE "ERROR IN Etest 3",!
K bsdxdie
N bsdxrestart S bsdxrestart=1
D RMCI^BSDX25(.ZZZ,APPTID)
IF +^BSDXTMP($J,1)'=0 WRITE "Error in Etest 4",!
QUIT
CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP
;Entry point for debugging
;
;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
Q
;
CHECKIN(BSDXY,BSDXAPPTID,BSDXCDT) ;Private EP Check in appointment
; Old additional vars: ,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)
; Called by RPC: BSDX CHECKIN APPOINTMENT
;
CHECKIN(BSDXY,BSDXAPTID,BSDXCDT) ; ,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP Check in appointment
; Private to GUI; use BSDXAPI for general API to checkin patients
; Parameters:
; BSDXY: Global Out
; BSDXAPPTID: Appointment ID in ^BSDXAPPT
; BSDXAPTID: Appointment ID in ^BSDXAPPT
; BSDXCDT: Checkin Date --> Changed
; BSDXCC: Clinic Stop IEN (not used)
; BSDXPRV: Provider IEN (not used)
; BSDXROU: Print Routing Slip? (not used)
; BSDXVCL: PCC+ Clinic IEN (not used)
; BSDXVFM: PCC+ Form IEN (not used)
; BSDXOG: PCC+ Outguide (true or false) (not used)
; BSDXOG: PCC+ Outguide (true or false)
;
; Output:
; ADO.net table with 1 column ErrorID, 1 row result
; - 0 if all okay
; - Another number or text if not
;
; Error reference:
; -1 -> Invalid Appointment ID
; -2 -> Invalid Check-in Date
; -3 -> Cannot check-in due to Fileman Filer failure
; -4 -> Cannot lock ^BSDXAPPT(APPTID)
; -10 -> BSDXAPI error
; -100 -> Mumps Error
;
; Turn off SDAM Appointment Events BSDX Protocol Processing
N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXIENS,BSDXVEN
N BSDXNOEV
S BSDXNOEV=1 ;Don't execute protocol
;
; Set min DUZ vars
D ^XBKVAR
;
; $ET
N $ET S $ET="G ERROR^BSDX25"
;
; Test for error trap for Unit Tests
I $G(BSDXDIE) N X S X=1/0
;
N BSDXI S BSDXI=0
;
S BSDXY=$NAME(^BSDXTMP($J))
K @BSDXY
;
D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
;
I '+BSDXAPPTID D ERR("-1~Invalid Appointment ID") QUIT
I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-1~Invalid Appointment ID") QUIT
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXAPPT(BSDXAPPTID):5 E D ERR("-4~Appt record is locked. Please contact technical support.") QUIT
;
I '+BSDXAPTID D ERR("BSDX25: Invalid Appointment ID") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("BSDX08: Invalid Appointment ID") Q
; Remove Date formatting v.1.5. Client will send date as FM Date.
;S:BSDXCDT["@0000" BSDXCDT=$P(BSDXCDT,"@")
;S %DT="T",X=BSDXCDT D ^%DT S BSDXCDT=Y
S BSDXCDT=+BSDXCDT ; Strip off zeros if C# sends them
I BSDXCDT'>2000000 D ERR("-2~Invalid Check-in Date") QUIT
I BSDXCDT=-1 D ERR(70) Q
I BSDXCDT>$$NOW^XLFDT S BSDXCDT=$$NOW^XLFDT
;
; Some data
N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0) ; Appointment Node
N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Appointment Start Time
;
; Get Hospital Location IEN from BSDXAPPT to BSDXRES (RESOUCE:HOSPITAL LOCATION)
N BSDXSC1 S BSDXSC1=$$GET1^DIQ(9002018.4,BSDXAPPTID_",",".07:.04","I")
I BSDXSC1,'$D(^SC(BSDXSC1,0)) S BSDXSC1="" ; Null it off if it doesn't exist
;
; Check if we can check-in using BSDXAPI
N BSDXERR S BSDXERR=0
I BSDXSC1 S BSDXERR=$$CHECKIC1^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
I BSDXERR D ERR(-10_"~"_$P(BSDXERR,U,2)) QUIT
;
;Checkin BSDX APPOINTMENT entry
; Failure Analysis: If we fail here, no changes were made.
N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,BSDXCDT)
I BSDXERR D ERR("-3~Fileman Filer failed to check-in appt") QUIT
D BSDXCHK(BSDXAPTID,BSDXCDT)
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
S BSDXPATID=$P(BSDXNOD,U,5)
S BSDXSTART=$P(BSDXNOD,U)
;
; File check-in using BSDXAPI
; Failure Analysis: If we fail here, we need to roll back first check-in.
N BSDXERR S BSDXERR=0
I BSDXSC1 S BSDXERR=$$CHECKIN1^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
I BSDXERR D QUIT
. N % S %=$$BSDXCHK(BSDXAPPTID,"@") ; No Error checking to prevent loop.
. D ERR(-10_"~"_$P(BSDXERR,U,2)) ; Send error message to client
S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I +$G(BSDXZ) D ERR($P(BSDXZ,U,2)) Q
. S BSDXNOD=^BSDXRES(BSDXSC1,0)
. S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
. I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APCHK(.BSDXZ,BSDXSC1,BSDXPATID,BSDXCDT,BSDXSTART)
;
L -^BSDXAPPT(BSDXAPPTID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)="0"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
BSDXCHK(BSDXAPPTID,BSDXCDT) ; $$ Private Entry Point. File or delete check-in to
; BSDX Appointment
; Input: BSDXAPPTID -> Appointment ID
; BSDXCDT -> Check-in date, or "@" to remove check-in.
BSDXCHK(BSDXAPTID,BSDXCDT) ;
;
; Output: 1^Error for error
; 0 for success
;
Q:$G(BSDXSIMERR1) 1_U_"Simulated Error 1"
;
N BSDXIENS,BSDXMSG,BSDXFDA ; Filer variables
S BSDXIENS=BSDXAPPTID_","
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.03)=BSDXCDT
D FILE^DIE("","BSDXFDA","BSDXMSG")
Q:$D(BSDXMSG) 1_U_BSDXMSG("DIERR",1,"TEXT",1)
Q 0
Q
;
RMCI(BSDXY,BSDXAPPTID) ; Private EP - Remove Check-in from BSDX APPT and 2/44
; Called by RPC BSDX REMOVE CHECK-IN
APCHK(BSDXZ,BSDXSC1,BSDXDFN,BSDXCDT,BSDXSTART) ;
;Checkin appointment for patient BSDXDFN in clinic BSDXSC1
;at time BSDXSTART
S BSDXZ=$$CHECKIN1^BSDXAPI(BSDXDFN,BSDXSC1,BSDXSTART)
Q
;
RMCI(BSDXY,BSDXAPPTID) ; EP - Remove Check-in from BSDX APPT and 2/44
; Called by RPC [Fill in later]
;
; Parameters to pass:
; APPTID: IEN in file BSDX APPOINTMENT
@ -146,9 +127,7 @@ RMCI(BSDXY,BSDXAPPTID) ; Private EP - Remove Check-in from BSDX APPT and 2/44
; -3~DB has corruption. Call Tech Support. (Resource ID doesn't exist in BSDXAPPT)
; -4~DB has corruption. Call Tech Support. (Resource ID in BSDXAPPT doesnt exist in BSDXRES)
; -5~BSDXAPI Error. Message depends on error.
; -6~Data Filing Error in BSDXCHK
; -7~Lock not acquired
; -100~Mumps Error
; -20~Mumps Error
;
N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
;
@ -162,56 +141,39 @@ RMCI(BSDXY,BSDXAPPTID) ; Private EP - Remove Check-in from BSDX APPT and 2/44
;
S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30) ; Header of ADO recordset
;
TSTART (BSDXI):SERIAL ; Perform Autolocking
;
;;;test
I $g(bsdxdie) S X=8/0
;;;
I $g(bsdxrestart) k bsdxrestart TRESTART
;;;test
I $G(BSDXDIE) N X S X=8/0
;
; Check for Appointment ID (passed and exists in file)
I '+$G(BSDXAPPTID) D ERR("-1~Invalid Appointment ID") QUIT
I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-2~Invalid Appointment ID") QUIT
;
; Lock
; Timeout not expected to happen except in error conditions.
L +^BSDXAPPT(BSDXAPPTID):5 E D ERR("-7~Appt record is locked. Please contact technical support.") QUIT
; Remove checkin from BSDX APPOINTMENT entry
D BSDXCHK(BSDXAPPTID,"@")
;
; Get appointment Data
; Now, remove checkin from PIMS files 2/44
N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0)
N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date
N BSDXRESID S BSDXRESID=$P(BSDXNOD,U,7) ; Resource ID
N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ; Resource ID
;
; If the resource doesn't exist, error out. DB is corrupt.
I 'BSDXRESID D ERR("-3~DB has corruption. Call Tech Support.") QUIT
I '$D(^BSDXRES(BSDXRESID,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
I 'BSDXSC1 D ERR("-3~DB has corruption. Call Tech Support.") QUIT
I '$D(^BSDXRES(BSDXSC1,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
;
; Get HL Data
N BSDXNOD S BSDXNOD=^BSDXRES(BSDXRESID,0) ; Resource 0 node
N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION IEN
I BSDXSC1,'$D(^SC(BSDXSC1,0)) S BSDXSC1="" ; Zero out if HL doesn't exist
N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0) ; Resource 0 node
S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
;
; Is it okay to remove check-in from PIMS?
N BSDXERR S BSDXERR=0 ; Scratch variable
; $$RMCICK = Remove Check-in Check
I BSDXSC1 S BSDXERR=$$RMCICK^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
I BSDXERR D ERR("-5~"_$P(BSDXERR,U,2)) QUIT
N BSDXZ ; Scratch variable to hold error message
I BSDXSC1]"",$D(^SC(BSDXSC1,0)) S BSDXZ=$$RMCI^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
I +$G(BSDXZ) D ERR("-5~"_$P(BSDXZ,U,2)) QUIT
;
; For possible rollback, get old check-in date (internal value)
N BSDXCDT S BSDXCDT=$$GET1^DIQ(9002018.4,BSDXAPPTID_",",.03,"I")
;
; Remove checkin from BSDX APPOINTMENT entry
; No need to rollback here on failure.
N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,"@")
I BSDXERR D ERR("-6~Cannot file data in $$BSDXCHK") QUIT
;
; Now, remove checkin from PIMS files 2/44
; Restore BSDXCDT into ^BSDXAPPT if we fail.
N BSDXERR S BSDXERR=0 ; Scratch variable to hold error message
I BSDXSC1 S BSDXERR=$$RMCI^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
I BSDXERR D QUIT
. N % S %=$$BSDXCHK(BSDXAPPTID,BSDXCDT) ; No error checking here.
. D ERR("-5~"_$P(BSDXERR,U,2)) ; Send error message to client
;
; Unlock
L -^BSDXAPPT(BSDXAPPTID)
TCOMMIT ; Save Data into Globals
;
; Return ADO recordset
S BSDXI=BSDXI+1
@ -245,11 +207,9 @@ CHKEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
Q:'+$G(BSDXRES) BSDXFOUND
Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
. N BSDXNOD S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
. S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
. I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
I BSDXFOUND,+$G(BSDXAPPT) D
. N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPT,BSDXSTAT)
. I BSDXERR D ^%ZTER ; VEN/SMH - This is silent. This is a last resort
I BSDXFOUND,+$G(BSDXAPPT) D BSDXCHK(BSDXAPPT,BSDXSTAT)
Q BSDXFOUND
;
CHKEVT3(BSDXRES) ;
@ -264,23 +224,16 @@ CHKEVT3(BSDXRES) ;
;
ERROR ;
S $ETRAP="D ^%ZTER HALT" ; Emergency Error Trap for the wise
; Rollback, otherwise ^XTER will be empty from future rollback
I $TL>0 TROLLBACK
D ^%ZTER
; VEN/SMH: NB: I make a conscious decision not to roll back anything
; here in the error trap. Once the error is fixed, users can
; undo or redo the check-in.
; Individual portions of this routine may choose to do rolling back
; of their own (e.g. a failed call to BSDXAPI causes rollback to occur
; in CHECKIN and RMCI)
;
S $EC="" ; Clear Error
; Log error message and send to client
D ERR("-100~Mumps Error")
Q:$Q "-100^Mumps Error" Q
D ERR("-20~Mumps Error")
Q
;
ERR(BSDXERR) ;Error processing
; Unlock first
L:$D(BSDXAPPTID) -^BSDXAPPT(BSDXAPPTID)
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
I $TLEVEL>0 TROLLBACK
S BSDXERR=$G(BSDXERR)
S BSDXERR=$P(BSDXERR,"~")_"~"_$TEXT(+0)_":"_$P(BSDXERR,"~",2) ; Append Routine Name
S BSDXI=$G(BSDXI)+1

115
m/BSDX26.m
View File

@ -1,27 +1,56 @@
BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:27am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Change History:
; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx.
; --> Thanks to Zach Gonzalez and Rick Marshall
; 3101205 - UJO/SMH - Extensive refactoring.
; 3120625 - VEN/SMH - Removal of Transactions, reloation of UTs to BSDXUT1
;
; Error Reference:
; 1: Appt ID is not a number
; 2: Appt IEN is not in ^BSDXAPPT
; 3: FM Failure to file WP field in ^BSDXAPPT
; 4: BSDXAPI reports failure to change note field in ^SC
; 5: Failure to acquire lock on ^BSDXAPPT(APPTID)
; 100: Mumps Error
;
; NB: Normally I use negative numbers for errors; this routine returns
; -1 as a successful result! So I needed to use +ve numbers.
; -1: Appt ID is not a number
; -2: Appt IEN is not in ^BSDXAPPT
; -3: FM Failure to file WP field in ^BSDXAPPT
;
EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
Q
UT ; Unit Tests
; Test 1: Make sure this damn thing works
N ZZZ
N %H S %H=$H
N NOTE S NOTE="New Note "_%H
D EDITAPT(.ZZZ,188,NOTE)
I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR",! B
; Test 2: Test Errors -1 and -2
N ZZZ
N NOTE S NOTE="Nothing important"
D EDITAPT(.ZZZ,"BLAHBLAH",NOTE)
I +^BSDXTMP($J,1)'=-1 W "ERROR IN -1",! B
D EDITAPT(.ZZZ,298734322,NOTE)
I +^BSDXTMP($J,1)'=-2 W "ERROR IN -2",! B
; Test 4: M Error
N bsdxdie S bsdxdie=1
D EDITAPT(.ZZZ,188,NOTE)
I +^BSDXTMP($J,1)'=-100 W "ERROR IN -100",! B
k bsdxdie
; Test 5: Trestart
N bsdxrestart S bsdxrestart=1
N %H S %H=$H
N NOTE S NOTE="New Note "_%H
D EDITAPT(.ZZZ,188,NOTE)
I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR in TRESTART",! B
; Test 6: for Hosp Location Update
N DATE S DATE=$$NOW^XLFDT()
S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform
D APPADD^BSDX07(.ZZZ,DATE,DATE+.001,3,"Dr Office",30,"Old Note",1)
N APPID S APPID=+$P(^BSDXTMP($J,1),U)
D EDITAPT(.ZZZ,APPID,"New Note")
I ^BSDXAPPT(APTID,1,1,0)'="New Note" W "Error in HL Section",! B
I $P(^SC(2,"S",DATE,1,1,0),U,4)'="New Note" W "Error in HL Section",! B
QUIT
;
EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE) ;EP Edit appointment (only note text can be edited)
; Called by RPC: BSDX EDIT APPOINTMENT
;
@ -47,35 +76,26 @@ EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE) ;EP Edit appointment (only note text can be
N BSDXI S BSDXI=0
; Header Node
S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
; Restartable txn for GT.M. Restored vars are Params + BSDXI.
TSTART (BSDXY,BSDXAPTID,BSDXNOTE,BSDXI):T="BSDX EDIT APPOINTMENT^BSDX26"
;
;;;test for error. See if %ZTER works
I $G(BSDXDIE) S X=1/0
;;;test for error inside transaction. See if %ZTER works
I $G(bsdxdie) S X=1/0
;;;test
;;;test for TRESTART
I $G(bsdxrestart) K bsdxrestart TRESTART
;;;test
;
; Validate Appointment ID
I '+BSDXAPTID D ERR(BSDXI,"1~BSDX26: Invalid Appointment ID") QUIT
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"2~BSDX26: Invalid Appointment ID") QUIT
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXAPPT(BSDXAPTID):5 E D ERR(BSDXI,"5~BSDX08: Appt record is locked. Please contact technical support.") QUIT
;
I '+BSDXAPTID D ERR(BSDXI,"-1~BSDX26: Invalid Appointment ID") QUIT
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-2~BSDX26: Invalid Appointment ID") QUIT
; Put the WP in decendant fields from the root to file as a WP field
S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
;
N BSDXMSG ; Message in case of error in filing.
;
; Save Before State in case we need it for rollback
K ^TMP($J)
M ^TMP($J,"BEFORE","BSDXAPPT")=^BSDXAPPT(BSDXAPTID)
;
; Update note in BSDX APPOINTMENT
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG")
;
; Error handling. No need for rollback since nothing else changed.
I $D(BSDXMSG) D ERR(BSDXI,"3~BSDX26: Fileman failure to file data into 9002018.4") QUIT
I $D(BSDXMSG) D ERR(BSDXI,"-3~BSDX26: Fileman failure to file data into 9002018.4") QUIT
;
; Now file in file 44:
N PTIEN S PTIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".05","I") ; Patient IEN
@ -83,33 +103,21 @@ EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE) ;EP Edit appointment (only note text can be
N DATE S DATE=+^BSDXAPPT(BSDXAPTID,0) ; Date of APPT
N BSDXRES S BSDXRES=0 ; Result
; Update Note only if we have a linked hospital location.
I HLIEN S BSDXRES=$$UPDATENT^BSDXAPI1(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
I HLIEN S BSDXRES=$$UPDATENOTE^BSDXAPI(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
; If we get an error (denoted by -1 in BSDXRES), return error to client
; AND restore the original note
I BSDXRES D ERR(BSDXI,"4~BSDX26: BSDXAPI reports an error: "_BSDXRES),ROLLBACK(BSDXAPTID) QUIT
;
;Return Recordset indicating success
L -^BSDXAPPT(BSDXAPTID)
I BSDXRES<0 D ERR(BSDXI,"-4~BSDX26: BSDXAPI reports an error: "_BSDXRES) QUIT
;Return Recordset
TCOMMIT
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)="-1"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
;
K ^TMP($J) ; Done; remove TMP data
QUIT
;
ROLLBACK(BSDXAPTID) ; Rollback note to original in ^BSDXAPPT
M ^BSDXAPPT(BSDXAPTID)=^TMP($J,"BEFORE","BSDXAPPT")
K ^TMP($J)
QUIT
;
ERR(BSDXI,BSDXERR) ;Error processing
; Unlock first
L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
I $TL>0 TROLLBACK
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
@ -117,8 +125,9 @@ ERR(BSDXI,BSDXERR) ;Error processing
;
ETRAP ;EP Error trap entry
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
I $TL>0 TROLLBACK
D ^%ZTER
;
S $EC=""
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(BSDXI,"100~BSDX26 Error: "_$G(%ZTERZE))
QUIT
D ERR(BSDXI,"-100~BSDX26 Error: "_$G(%ZTERZE))
Q

2
m/BSDX27.m
View File

@ -1,5 +1,5 @@
BSDX27 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log: July 15, 2010

7
m/BSDX28.m
View File

@ -1,5 +1,5 @@
BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:57am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Change Log:
; HMW 3050721 Added test for inactivated record
@ -75,7 +75,8 @@ DOB ;DOB Lookup
. . Q
. Q
;
CHART ;Chart# Lookup
CHART
;Chart# Lookup
I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
. S BSDXIEN=0 F S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D Q
. . Q:'$D(^DPT(BSDXIEN,0))

50
m/BSDX29.m
View File

@ -1,5 +1,5 @@
BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/9/12 11:50am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:
@ -7,15 +7,13 @@ BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/9/12 11:50am
; - Beginning and Ending dates passed as FM Dates
; v1.42 by WV/SMH on 3101023
; - Transaction moved; now restartable too.
; --> Thanks to Zach Gonzalez and Rick Marshall.
; - Refactoring of major portions of routine
; v1.7 by VEN/SMH on 3120622
; - Removed transaction code; Locks added in update to prevent concurrent
; update
;
BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
Q
;
BSDXCP(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
@ -43,13 +41,13 @@ BSDXCP(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00100ERRORID"_$C(30)
;
; Make dates inclusive; add 1 to FM dates
S BSDXBEG=$$FMADD^XLFDT(BSDXBEG,-1)
S BSDXEND=$$FMADD^XLFDT(BSDXEND,+1)
S BSDXBEG=BSDXBEG-1
S BSDXEND=BSDXEND+1
;
; Taskman variables
N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE,ZTIO
N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
; Task Load
S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS",ZTIO=""
S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS"
S ZTSAVE("BSDXBEG")="",ZTSAVE("BSDXEND")="",ZTSAVE("BSDX44")="",ZTSAVE("BSDXRES")=""
D ^%ZTLOAD
; Set up return ADO.net dataset
@ -66,10 +64,10 @@ ZTM ;EP - Taskman entry point
; Variables set up in ZTSAVE above
;
Q:'$D(ZTSK)
;
; $ET
N $ET S $ET="G ZTMERR^BSDX29"
;
; Txn
TSTART (BSDXBEG,BSDXEND,BSDX44,BSDXRES):T="BSDX COPY APPOINTMENT^BSDX29"
;$O through ^SC(BSDX44,"S",
N BSDXCNT S BSDXCNT=0 ; Count of Copied Appointments
N BSDXQUIT S BSDXQUIT=0 ; Quit Flag to be retrieved from an external proc
@ -84,7 +82,7 @@ ZTM ;EP - Taskman entry point
. . N BSDXNOD S BSDXNOD=$G(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN,0)) ; Node
. . Q:'+BSDXNOD ; Quit if no node
. . N BSDXCAN S BSDXCAN=$P(BSDXNOD,U,9) ; Cancel flag
. . Q:BSDXCAN="C" ; Quit if appt cancelled -- smh - this will never happen; cancelled appointments are normally removed from 44
. . Q:BSDXCAN="C" ; Quit if appt cancelled
. . N BSDXPAT S BSDXPAT=$P(BSDXNOD,U) ; Patient
. . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) ;duration in minutes
. . N BSDXCLRK S BSDXCLRK=$P(BSDXNOD,U,6) ;appt made by (clerk)
@ -92,15 +90,20 @@ ZTM ;EP - Taskman entry point
. . N BSDXNOTE S BSDXNOTE=$P(BSDXNOD,U,4) ;'OTHER' field contains note
. . S BSDXCNT=BSDXCNT+$$XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE)
. . I +BSDXCNT,BSDXCNT#10=0 S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT_" records copied." ;every 10th record
. . I $D(^BSDXTMP("BSDXCOPY",ZTSK,"CANCEL")) S BSDXQUIT=1 ;Check for cancel flag ; smh - not used currently (v1.7)
;
;
. . I $D(^BSDXTMP("BSDXCOPY",ZTSK,"CANCEL")) S BSDXQUIT=1 ;Check for cancel flag
. . Q
. Q
I 'BSDXQUIT TCOMMIT
E TROLLBACK
S ^BSDXTMP("BSDXCOPY",ZTSK)=$S(BSDXQUIT:"Cancelled. No records copied.",1:"Finished. "_BSDXCNT_" records copied.")
Q
;
ZTMERR ; For now, error from TM is only in trap; not returned to client.
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
; Rollback before logging the error
I $TL>0 TROLLBACK
D ^%ZTER
S $EC="" ; Clear Error
QUIT
;
XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
@ -108,12 +111,8 @@ XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
;Copy record to BSDX APPOINTMENT file
;Return 1 if record copied, otherwise 0
;
N REF
S REF=$NA(^BSDXLOCK(BSDXRES,BSDXBEG,BSDXPAT)) ; This combo is unique
L +@REF:0 E Q 0
;
;$O Thru ^BSDXAPPT to determine if this appt already added
N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2,BSDXNOD
N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2
S BSDXIEN=0,BSDXFND=0
F S BSDXIEN=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXBEG,BSDXIEN)) Q:'+BSDXIEN D Q:BSDXFND
. S BSDXNOD=$G(^BSDXAPPT(BSDXIEN,0))
@ -122,13 +121,12 @@ XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
. S BSDXFND=0
. I BSDXPAT2=BSDXPAT S BSDXFND=1
. Q
I BSDXFND L -@REF Q 0
Q:BSDXFND 0
;
;Add to BSDX APPOINTMENT
S BSDXEND=BSDXBEG
;Calculate ending time from beginning time and duration.
S BSDXEND=$$ADDMIN(BSDXBEG,BSDXLEN)
N BSDXFDA,BSDXIENS
S BSDXIENS="+1,"
S BSDXFDA(9002018.4,BSDXIENS,.01)=BSDXBEG
S BSDXFDA(9002018.4,BSDXIENS,.02)=BSDXEND
@ -138,21 +136,17 @@ XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
S BSDXFDA(9002018.4,BSDXIENS,.09)=BSDXMADE
;
K BSDXIEN
;
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXIEN=+$G(BSDXIEN(1))
I '+BSDXIEN L -@REF Q 0
I '+BSDXIEN Q 0
;
;Add WP field
I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" D
. D WP^DIE(9002018.4,BSDXIEN_",",1,"","BSDXNOTE","BSDXMSG")
L -@REF
;
Q 1
;
ERR(BSDXI,BSDXCNT,BSDXERR) ;Error processing
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
S ^BSDXTMP($J,BSDXI)=BSDXCNT_"^"_BSDXERR_$C(30)

12
m/BSDX2E.m
View File

@ -1,5 +1,5 @@
BSDX2E ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [7/11/12 9:37am]
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX2E ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [4/28/11 10:28am]
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
S LINE="",$P(LINE,"*",81)=""
@ -23,7 +23,7 @@ VERSION ;
;Is the PIMS requirement present?
Q:'$$VERCHK("SD",5.3)
; Q:'$$PATCHCK("PIMS*5.3*1003") D
Q:'$$VERCHK("BMX",4)
Q:'$$VERCHK("BMX",2)
;
OTHER ;
;Other checks
@ -90,7 +90,7 @@ V0200 ;EP Version 1.5 PostInit
. S BSDXFDA(101.01,"+1,"_BSDXDA_",","3")=BSDXSEQ
. D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
. ; Error message
. I $D(BSDXMSG) D MES^XPDUTL("Error: ",BSDXMSG("DIERR",1,"TEXT",1))
. I $D(BSDXMSG) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
;
; Remove nassssty protocols ORU PATIENT MOVMT and DVBA C&P SCHD EVENT
; SDAM APPOINTMENT EVENTS IENS for use in FIND1^DIC
@ -105,7 +105,7 @@ V0200 ;EP Version 1.5 PostInit
S:DVBAIEN>0 BSDXFDA(101.01,DVBAIEN_SDEVTIENS,.01)="@"
D:$D(BSDXFDA) FILE^DIE("","BSDXFDA","BSDXMSG")
; If error
I $D(BSDXMSG) D MES^XPDUTL("Error: ",BSDXMSG("DIERR",1,"TEXT",1))
I $D(BSDXMSG) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
;
;
; Now put in the default values for parameters
@ -116,7 +116,7 @@ V0200 ;EP Version 1.5 PostInit
D PUT^XPAR("PKG","BSDX AUTO PRINT RS",1,0,.BSDXERR)
I $G(BSDXERR) W $C(7),"Error: ",BSDXERR
D PUT^XPAR("PKG","BSDX AUTO PRINT AS",1,0,.BSDXERR)
I $G(BSDXERR) D MES^XPDUTL("Error: ",BSDXERR)
I $G(BSDXERR) W $C(7),"Error: ",BSDXERR
QUIT
;
SORRY(XPX) ;

27
m/BSDX30.m
View File

@ -1,12 +1,12 @@
BSDX30 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [7/6/12 11:03am]
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX30 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [4/28/11 10:28am]
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;
SPACED(BSDXY,BSDXDIC,BSDXVAL) ;EP
;Entry point for debugging
;
; D DEBUG^%Serenji("SPACE^BSDX30(.BSDXY,BSDXDIC,BSDXVAL)")
D DEBUG^%Serenji("SPACE^BSDX30(.BSDXY,BSDXDIC,BSDXVAL)")
Q
;
SPACE(BSDXY,BSDXDIC,BSDXVAL) ;EP
@ -48,7 +48,7 @@ ETRAP ;EP Error trap entry
;
EHRPTD(BSDXY,BSDXWID,BSDXDFN) ;
;
; D DEBUG^%Serenji("EHRPT^BSDX30(.BSDXY,BSDXWID,BSDXDFN)")
D DEBUG^%Serenji("EHRPT^BSDX30(.BSDXY,BSDXWID,BSDXDFN)")
Q
;
EHRPT(BSDXY,BSDXWID,BSDXDFN) ;
@ -69,9 +69,6 @@ EHRPT(BSDXY,BSDXWID,BSDXDFN) ;
Q
;
PEVENT(BSDXWID,DFN) ;EP - Raise patient selection event to EHR
; VEN/SMH v1.7 3120706 - Not used in VISTA.
; No way right now to synchronize with CPRS.
; Code commented out for now.
;
;Change patient context to patient DFN
;on all EHR client sessions associated with user DUZ
@ -80,14 +77,14 @@ PEVENT(BSDXWID,DFN) ;EP - Raise patient selection event to EHR
;If BSDXWID is "", the context change is sent to
;all EHR client sessions belonging to user DUZ.
;
;Q:'$G(DUZ)
Q:'$G(DUZ)
;N X
;S X="CIANBUTL" X ^%ZOSF("TEST") Q:'$T
;S X="CIANBEVT" X ^%ZOSF("TEST") Q:'$T
;N UID,BRET
;S BRET=0,UID=0
;F S BRET=$$NXTUID^CIANBUTL(.UID,1) Q:'UID D
;. Q:DUZ'=$$GETVAR^CIANBUTL("DUZ",,,UID)
;. I BSDXWID'="" Q:BSDXWID'=$TR($$GETVAR^CIANBUTL("WID",,,UID),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;. D QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN,UID)
;Q
N UID,BRET
S BRET=0,UID=0
F S BRET=$$NXTUID^CIANBUTL(.UID,1) Q:'UID D
. Q:DUZ'=$$GETVAR^CIANBUTL("DUZ",,,UID)
. I BSDXWID'="" Q:BSDXWID'=$TR($$GETVAR^CIANBUTL("WID",,,UID),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
. D QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN,UID)
Q

180
m/BSDX31.m
View File

@ -1,16 +1,11 @@
BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:39am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:28am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Change Log:
; v1.42 3101023 WV/SMH - Change transaction to restartable.
; v1.42 3101206 UJO/SMH - Extensive refactoring
; v1.7 3120626 VEN/SMH - Removed transactions; extensive refactoring
; - Moved APTNS (whatever it was) to BSDXAPI1
; as $$NOSHOW
; - Made BSDXNOS extrinsic.
; - Moved Unit Tests to BSDXUT1
; - BSDXNOS deletes no-show rather than file 0 for
; undoing a no show
; v1.42 Oct 23 2010 WV/SMH
; - Change transaction to restartable. Thanks to Zach Gonzalez
; --> and Rick Marshall for their help.
; v1.42 Dec 6 2010: Extensive refactoring
;
; Error Reference:
; -1: zero or null Appt ID
@ -18,17 +13,48 @@ BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:39am
; -3: No-show flag is invalid
; -4: Filing of No-show in ^BSDXAPPT failed
; -5: Filing of No-show in ^DPT failed (BSDXAPI error)
; -6: Invalid Resource ID
; -7: Lock not acquired on ^BSDXAPPT(BSDXAPTID)
; -100: M Error
;
;
NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP
;Entry point for debugging
;
; D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
Q
;
UT ; Unit Tests
; Test 1: Sanity Check
N ZZZ ; Garbage return variable
N DATE S DATE=$$NOW^XLFDT()
S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform
D APPADD^BSDX07(.ZZZ,DATE,DATE+.0001,3,"Dr Office",30,"Old Note",1)
N APPID S APPID=+$P(^BSDXTMP($J,1),U)
D NOSHOW(.ZZZ,APPID,1)
I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T1",! B
I $P(^DPT(3,"S",DATE,0),U,2)'="N" W "ERROR T1",! B
; Test 2: Undo noshow
D NOSHOW(.ZZZ,APPID,0)
I $P(^BSDXAPPT(APPID,0),U,10)'="0" W "ERROR T2",! B
I $P(^DPT(3,"S",DATE,0),U,2)'="" W "ERROR T2",! B
; Test 3: -1
D NOSHOW(.ZZZ,"",0)
I $P(^BSDXTMP($J,1),U)'=-1 W "ERROR T3",! B
; Test 4: -2
D NOSHOW(.ZZZ,2938748233,0)
I $P(^BSDXTMP($J,1),U)'=-2 W "ERROR T4",! B
; Test 5: -3
D NOSHOW(.ZZZ,APPID,3)
I $P(^BSDXTMP($J,1),U)'=-3 W "ERROR T5",! B
; Test 6: Mumps error (-100)
s bsdxdie=1
D NOSHOW(.ZZZ,APPID,1)
I $P(^BSDXTMP($J,1),U)'=-100 W "ERROR T6",! B
k bsdxdie
; Test 7: Restartable transaction
s bsdxrestart=1
D NOSHOW(.ZZZ,APPID,1)
I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T7",! B
QUIT
NOSHOW(BSDXY,BSDXAPTID,BSDXNS) ;EP - No show a patient
; Called by RPC: BSDX NOSHOW
; Sets appointment noshow flag in BSDX APPOINTMENT file and "S" node in File 2
@ -46,100 +72,84 @@ NOSHOW(BSDXY,BSDXAPTID,BSDXNS) ;EP - No show a patient
; Return Array; set and clear
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
;
; $ET
N $ET S $ET="G ETRAP^BSDX31"
;
; Basline vars
D ^XBKVAR ; Set up baseline variables (DUZ, DUZ(2)) if they don't exist
;
; Counter
N BSDXI S BSDXI=0
;
; Header Node
S ^BSDXTMP($J,BSDXI)="I00100ERRORID^T00030ERRORTEXT"_$C(30)
;
;;;test for error. See if %ZTER works
I $G(BSDXDIE) N X S X=1/0
; Begin transaction
TSTART (BSDXI,BSDXY,BSDXAPTID,BSDXNS):T="BSDX NOSHOW CANCEL^BSDX29"
;;;test for error inside transaction. See if %ZTER works
I $G(bsdxdie) S X=1/0
;;;TEST
;
;;;test for TRESTART
I $G(bsdxrestart) K bsdxrestart TRESTART
;;;test
; Turn off SDAM APPT PROTOCOL BSDX Entries
N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
;
; Appointment ID check
I '+BSDXAPTID D ERR(-1,"BSDX31: Invalid Appointment ID") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(-2,"BSDX31: Invalid Appointment ID") Q
;
; Lock BSDX node, only to synchronize access to the globals.
; It's not expected that the error will ever happen as no filing
; is supposed to take 5 seconds.
L +^BSDXAPPT(BSDXAPTID):5 E D ERR(-7,"BSDX31: Appt record is locked. Please contact technical support.") Q
;
; Noshow value check - Must be 1 or 0
S BSDXNS=+BSDXNS
I BSDXNS'=1&(BSDXNS'=0) D ERR(-3,"BSDX31: Invalid No Show value") Q
;
; Get Some data
N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; Node
N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date/Time
N BSDXRES S BSDXRES=$P(BSDXNOD,U,7) ; Resource ID
;
; Check if Resource ID is missing or invalid
I BSDXRES="" D ERR(-6,"BSDX31: Invalid Resource") QUIT
I '$D(^BSDXRES(BSDXRES,0)) D ERR(-6,"BSDX31: Invalid Resource") QUIT
;
; Get the Hospital Location
N BSDXRESNOD S BSDXRESNOD=^BSDXRES(BSDXRES,0)
N BSDXLOC S BSDXLOC=$P(BSDXRESNOD,U,4) ;HOSPITAL LOCATION
I BSDXLOC,'$D(^SC(BSDXLOC,0)) S BSDXLOC="" ; Unlink it if it doesn't exist
; I can go and then delete it from ^BSDXRES like Mailman code which tries
; to be too helpful... but I will postpone that until this is a need.
;
; Check if it's okay to no-show patient.
N BSDXERR S BSDXERR=0 ; Error variable
I BSDXLOC S BSDXERR=$$NOSHOWCK^BSDXAPI1(BSDXPATID,BSDXLOC,BSDXSTART,BSDXNS)
I BSDXERR D ERR(-5,"BSDX31: "_$P(BSDXERR,U,2)) QUIT
;
; Simulated Error
I $G(BSDXSIMERR1) D ERR(-4,"BSDX31: Simulated Error") QUIT
; Edit BSDX APPOINTMENT entry No-show field
; Failure Analysis: If we fail here, no rollback needed, as this is the 1st
; call
N BSDXMSG S BSDXMSG=$$BSDXNOS(BSDXAPTID,BSDXNS)
I BSDXMSG D ERR(-4,"BSDX31: "_$P(BSDXMSG,U,2)) QUIT
;
; Edit BSDX APPOINTMENT entry
N BSDXMSG ;
D BSDXNOS(BSDXAPTID,BSDXNS,.BSDXMSG) ;Edit BSDX APPOINTMENT entry NOSHOW field
I $D(BSDXMSG("DIERR")) S BSDXMSG=$G(BSDXMSG("DIERR",1,"TEXT",1)) D ERR(-4,"BSDX31: "_BSDXMSG) Q
; Edit File 2 "S" node entry
; Failure Analysis: If we fail here, we need to rollback the BSDX
; Apptointment Entry
N BSDXERR S BSDXERR=0 ; Error variable
; If HL exist, (resource is linked to PIMS), file no show in File 2
I BSDXLOC S BSDXERR=$$NOSHOW^BSDXAPI1(BSDXPATID,BSDXLOC,BSDXSTART,BSDXNS)
I BSDXERR D QUIT
. D ERR(-5,"BSDX31: "_$P(BSDXERR,U,2))
. N % S %=$$BSDXNOS(BSDXAPTID,'BSDXNS) ; no error checking for filer
N BSDXZ,BSDXERR ; Error variables to control looping
S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
; If Resource ID exists, and HL exists (means that Resource is linked), No show in File 2
I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I $G(BSDXZ)]"" S BSDXERR="BSDX31: APNOSHO Returned: "_BSDXZ D ERR(-5,BSDXERR) Q
. S BSDXNOD=^BSDXRES(BSDXSC1,0)
. S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
. I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APNOSHO(.BSDXZ,BSDXSC1,BSDXPATID,BSDXSTART,BSDXNS)
;
; Unlock
L -^BSDXAPPT(BSDXAPTID)
;
; Return data in ADO.net table
TCOMMIT
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)="1^"_$C(30) ; 1 means everything okay
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
QUIT
;
BSDXNOS(BSDXAPTID,BSDXNS) ; $$ Private; File/unfile noshow in ^BSDXAPPT
; in v1.7 I delete the no-show value rather than file zero
N BSDXFDA,BSDXIENS,BSDXMSG
N BSDXVALUE ; What to file: 1 or delete it.
I BSDXNS S BSDXVALUE=1
E S BSDXVALUE="@"
APNOSHO(BSDXZ,BSDXSC1,BSDXDFN,BSDXSD,BSDXNS) ;
; update file 2 info
;Set noshow for patient BSDXDFN in clinic BSDXSC1
;at time BSDXSD
N BSDXC,%H,BSDXCDT,BSDXIEN
N BSDXIENS,BSDXFDA,BSDXMSG
S %H=$H D YMD^%DTC
S BSDXCDT=X+%
;
S BSDXIENS=BSDXSD_","_BSDXDFN_","
I +BSDXNS D
. S BSDXFDA(2.98,BSDXIENS,3)="N"
. S BSDXFDA(2.98,BSDXIENS,14)=DUZ
. S BSDXFDA(2.98,BSDXIENS,15)=BSDXCDT
E D
. S BSDXFDA(2.98,BSDXIENS,3)=""
. S BSDXFDA(2.98,BSDXIENS,14)=""
. S BSDXFDA(2.98,BSDXIENS,15)=""
K BSDXIEN
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXZ=$G(BSDXMSG("DIERR",1,"TEXT",1))
Q
;
BSDXNOS(BSDXAPTID,BSDXNS,BSDXMSG) ;
;
N BSDXFDA,BSDXIENS
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXVALUE ;NOSHOW 1 or 0
S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXNS ;NOSHOW
D FILE^DIE("","BSDXFDA","BSDXMSG")
QUIT:$D(BSDXMSG) -1_U_BSDXMSG("DIERR",1,"TEXT",1)
QUIT 0
QUIT
;
NOSEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX NOSHOW APPOINTMENT event
;when appointments NOSHOW via PIMS interface.
@ -162,15 +172,14 @@ NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
;Get appointment id in BSDXAPT
;If found, call BSDXNOS(BSDXAPPT) and return 1
;else return 0
N BSDXFOUND,BSDXAPPT,BSDXNOD
N BSDXFOUND,BSDXAPPT
S BSDXFOUND=0
Q:'+$G(BSDXRES) BSDXFOUND
Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
. S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
. I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
I BSDXFOUND,+$G(BSDXAPPT) N BSDXMSG S BSDXMSG=$$BSDXNOS(BSDXAPPT,BSDXSTAT)
I BSDXMSG D ^%ZTER ; Last ditch error handling. This is supposed to be silently called from the protocol file.
I BSDXFOUND,+$G(BSDXAPPT) D BSDXNOS(BSDXAPPT,BSDXSTAT)
Q BSDXFOUND
;
NOSEVT3(BSDXRES) ;
@ -185,12 +194,9 @@ NOSEVT3(BSDXRES) ;
;
;
ERR(BSDXERID,ERRTXT) ;Error processing
; Unlock first
L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
; If last line is $C(31), we are done. No more errors to send to client.
I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
S BSDXI=BSDXI+1
S ERRTXT=$TR(ERRTXT,"^","~")
I $TL>0 TROLLBACK
S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
@ -198,12 +204,14 @@ ERR(BSDXERID,ERRTXT) ;Error processing
;
ETRAP ;EP Error trap entry
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
; Rollback, otherwise ^XTER will be empty from future rollback
I $TL>0 TROLLBACK
D ^%ZTER
;
S $EC="" ; Clear Error
; Send to client
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(-100,"BSDX31 Error: "_$G(%ZTERZE))
Q:$Q 100_U_"Mumps Error" Q
QUIT
;
IMHERE(BSDXRES) ;EP
;Entry point for BSDX IM HERE remote procedure

2
m/BSDX32.m
View File

@ -1,5 +1,5 @@
BSDX32 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/11/11 10:39am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDX33.m
View File

@ -1,5 +1,5 @@
BSDX33 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
; Mods by WV/STAR
;

2
m/BSDX34.m
View File

@ -1,5 +1,5 @@
BSDX34 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
; Change Log:

4
m/BSDX35.m
View File

@ -1,5 +1,5 @@
BSDX35 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 6/21/12 3:57pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDX35 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;

412
m/BSDXAPI.m
View File

@ -1,18 +1,43 @@
BSDXAPI ; IHS/LJF,HMW,MAW & VEN/SMH - SCHEDULING APIs ; 7/10/12 5:58pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 4/28/11 10:30am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;Orignal routine is BSDAPI by IHS/LJF, HMW, and MAW
; mods (many) by WV/SMH
;local mods (many) by WV/SMH
;Move to BSDX namespace as BSDXAPI from BSDAPI by WV/SMH
; Change history is located in BSDXAPI1 (to save space).
; Change History:
; 2010-11-5: (1.42)
; - Fixed errors having to do uncanceling patient appointments if it was a patient cancelled appointment.
; - Use new style Fileman API for storing appointments in file 44 in $$MAKE due to problems with legacy API.
; 2010-11-12: (1.42)
; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well.
; 2010-12-5 (1.42)
; Added an entry point to update the patient note in file 44.
; 2010-12-6 (1.42)
; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI")
; 2010-12-8 (1.42)
; Removed restriction on max appt length. Even though this restriction
; exists in fileman (120 minutes), PIMS ignores it. Therefore, I
; will ignore it here too.
; 2011-01-25 (v.1.5)
; Added entry point $$RMCI to remove checked in appointments.
; In $$CANCEL, if the appointment is checked in, delete check-in rather than
; spitting an error message to the user saying 'Delete the check-in'
; Changed all lines that look like this:
; I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
; to:
; I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
; to allow for date at midnight which does not have a dot at the end.
; 2011-01-26 (v.1.5)
; More user friendly message if patient already has appointment in $$MAKE:
; Spits out pt name and user friendly date.
;
;
MAKE1(DFN,CLIN,TYP,DATE,LEN,INFO) ; Simplified PEP w/ parameters for $$MAKE - making appointment
; Call like this for DFN 23435 having an appointment at Hospital Location 33
; have 3 (scheduled) or 4 (walkin) appt at Dec 20, 2009 @ 10:11:59 for 30 minutes appt
; for Baby foxes hallucinations.
; S RESULT=$$MAKE1^BSDXAPI(23435,33,(3 or 4),3091220.221159,30,"I see Baby foxes")
N BSDR
S BSDR("PAT")=DFN ;DFN
S BSDR("CLN")=CLIN ;Hosp Loc IEN
S BSDR("TYP")=TYP ;3 sched or 4 walkin
@ -39,15 +64,35 @@ MAKE(BSDR) ;PEP; call to store appt made
; = 0 or null: everything okay
; = 1^message: error and reason
;
N BSDXMKCK S BSDXMKCK=$$MAKECK(.BSDR) ; Check if we can make appointment
I BSDXMKCK Q BSDXMKCK ; If we can't, quit with the reason why.
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I ($G(BSDR("TYP"))<3)!($G(BSDR("TYP"))>4) Q 1_U_"Appt Type error: "_$G(BSDR("TYP"))
I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12) ;remove seconds
I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
;
;Otherwise, we continue
;I ($G(BSDR("LEN"))<5)!($G(BSDR("LEN"))>240) Q 1_U_"Appt Length error: "_$G(BSDR("LEN")) ; v 1.42 - no check on length is done anymore. see top comments for details.
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
;I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)'["C" Q 1_U_"Patient "_BSDR("PAT")_" already has appt at "_BSDR("ADT") ; v.1.5 more user friendly err msg
;
N BSDXFDA,BSDXIENS,BSDXMSG ; FILE/UPDATE^DIE variables
; Following block to give an error message to user if there is already an appointment for patient. More verbose than others.
N BSDXERR ; place to store error message
I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)'["C" DO QUIT BSDXERR ; If there's an appt in the "S" node of file 2 and it's not cancelled
. S BSDXERR=1_U_"Patient "_$P(^DPT(BSDR("PAT"),0),U)_" ("_BSDR("PAT")_") "
. S BSDXERR=BSDXERR_"already has appt at "_$$FMTE^XLFDT(BSDR("ADT"))
. N BSDXSCIEN S BSDXSCIEN=$P(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0),U) ; Clinic IEN in ^SC (0 piece of 0 node of "S" multiple in file 2)
. N BSDXSCNAM S BSDXSCNAM=$P(^SC(BSDXSCIEN,0),U) ; PIMS Name of Clinic
. S BSDXERR=BSDXERR_$C(13,10)_"PIMS clinic: "_BSDXSCNAM ; tell the user of the PIMS clinic
. I $D(^BSDXRES("ALOC",BSDXSCIEN)) DO ; if the Clinic is linked to a BSDX Resource (we find out using the index ALOC in the BSDX RESOURCE file)
. . N BSDXRESIEN S BSDXRESIEN=$O(^BSDXRES("ALOC",BSDXSCIEN,""))
. . QUIT:'BSDXRESIEN ; Safeguard if index is corrupt
. . N BSDXRESNAM S BSDXRESNAM=$P(^BSDXRES(BSDXRESIEN,0),U)
. . S BSDXERR=BSDXERR_$C(13,10)_"Scheduling GUI clinic: "_BSDXRESNAM ; tell the user of the BSDX clinic
;
NEW DIC,DA,Y,X,DD,DO,DLAYGO
;
I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)["C" D
. ; "un-cancel" existing appt in file 2
. N BSDXFDA,BSDXIENS,BSDXMSG
. S BSDXIENS=BSDR("ADT")_","_BSDR("PAT")_","
. S BSDXFDA(2.98,BSDXIENS,".01")=BSDR("CLN")
. S BSDXFDA(2.98,BSDXIENS,"3")=""
@ -56,37 +101,27 @@ MAKE(BSDR) ;PEP; call to store appt made
. S BSDXFDA(2.98,BSDXIENS,"14")=""
. S BSDXFDA(2.98,BSDXIENS,"15")=""
. S BSDXFDA(2.98,BSDXIENS,"16")=""
. S BSDXFDA(2.98,BSDXIENS,"17")="@" ; v 1.7; cancellation remarks were left over
. S BSDXFDA(2.98,BSDXIENS,"19")=""
. S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
. D FILE^DIE("","BSDXFDA","BSDXMSG")
Q:$D(BSDXMSG) 1_U_"Fileman edit to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
;
Q:$G(BSDXSIMERR2) 1_U_$NA(BSDXSIMERR2) ; Unit Test line
;
E D ; File new appointment/edit existing appointment in file 2
. N BSDXTEMP S BSDXTEMP=$G(BSDXMSG)
E D I $G(BSDXERR(1)) Q 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")
. N BSDXFDA,BSDXIENS,BSDXMSG
. S BSDXIENS="?+2,"_BSDR("PAT")_","
. S BSDXIENS(2)=BSDR("ADT")
. S BSDXFDA(2.98,BSDXIENS,.01)=BSDR("CLN")
. S BSDXFDA(2.98,BSDXIENS,"9")=BSDR("TYP")
. S BSDXFDA(2.98,BSDXIENS,"9.5")=9
. S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
. D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXMSG")
Q:$D(BSDXMSG) 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
;
Q:$G(BSDXSIMERR3) 1_U_$NA(BSDXSIMERR3) ; Unit Test line
;
; add appt to file 44. This adds it to the FIRST subfile (Appointment)
N DIC,DA,Y,X,DD,DO,DLAYGO,DINUM
. D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXERR(1)")
; add appt to file 44
K DIC,DA,X,Y,DLAYGO,DD,DO
I '$D(^SC(BSDR("CLN"),"S",0)) S ^SC(BSDR("CLN"),"S",0)="^44.001DA^^"
I '$D(^SC(BSDR("CLN"),"S",BSDR("ADT"),0)) D I Y<1 Q 1_U_"Error adding date to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")
. S DIC="^SC("_BSDR("CLN")_",""S"",",DA(1)=BSDR("CLN"),(X,DINUM)=BSDR("ADT")
. S DIC("P")="44.001DA",DIC(0)="L",DLAYGO=44.001
. S Y=1 I '$D(@(DIC_X_")")) D FILE^DICN
;
Q:$G(BSDXSIMERR4) 1_U_$NA(BSDXSIMERR4) ; Unit Test line
;
; add appt for file 44, second subfile (Appointment/Patient)
; Sep 28 2010: Changed old style API to new style API. Keep for reference //smh
;K DIC,DA,X,Y,DLAYGO,DD,DO,DINUM
;S DIC="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
@ -107,12 +142,6 @@ MAKE(BSDR) ;PEP; call to store appt made
;
I $D(BSDXERR) Q 1_U_"Error adding appt to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")_" Patient="_BSDR("PAT")_" Error: "_BSDXERR("DIERR",1,"TEXT",1)
;
;Q:$G(BSDXSIMERR5) 1_U_$NA(BSDXSIMERR5) ; Unit Test line
S:$G(BSDXSIMERR5) X=1/0
;
; Update the Availablilities ; Doesn't fail. Global reads and sets.
D AVUPDTMK^BSDXAPI1(BSDR("CLN"),BSDR("ADT"),BSDR("LEN"),BSDR("PAT"))
;
; call event driver
NEW DFN,SDT,SDCL,SDDA,SDMODE
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2
@ -120,67 +149,10 @@ MAKE(BSDR) ;PEP; call to store appt made
D MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,SDMODE)
Q 0
;
MAKECK(BSDR) ; $$ - Is it okay to make an appointment? ; PEP
; Input: Same as $$MAKE
; Output: 1^error or 0 for success
; NB: This subroutine saves no data. Only checks whether it's okay.
;
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I ($G(BSDR("TYP"))<3)!($G(BSDR("TYP"))>4) Q 1_U_"Appt Type error: "_$G(BSDR("TYP"))
I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12) ;remove seconds
I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
;
; Appt Length check removed in v 1.5
;
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
; More verbose error message in v1.5
; Following block to give an error message to user if there is already an appointment for patient. More verbose than others.
N BSDXERR ; place to store error message
I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)'["C" DO QUIT BSDXERR ; If there's an appt in the "S" node of file 2 and it's not cancelled
. S BSDXERR=1_U_"Patient "_$P(^DPT(BSDR("PAT"),0),U)_" ("_BSDR("PAT")_") "
. S BSDXERR=BSDXERR_"already has appt at "_$$FMTE^XLFDT(BSDR("ADT"))
. N BSDXSCIEN S BSDXSCIEN=$P(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0),U) ; Clinic IEN in ^SC (0 piece of 0 node of "S" multiple in file 2)
. N BSDXSCNAM S BSDXSCNAM=$P(^SC(BSDXSCIEN,0),U) ; PIMS Name of Clinic
. S BSDXERR=BSDXERR_$C(13,10)_"PIMS clinic: "_BSDXSCNAM ; tell the user of the PIMS clinic
. I $D(^BSDXRES("ALOC",BSDXSCIEN)) DO ; if the Clinic is linked to a BSDX Resource (we find out using the index ALOC in the BSDX RESOURCE file)
. . N BSDXRESIEN S BSDXRESIEN=$O(^BSDXRES("ALOC",BSDXSCIEN,""))
. . QUIT:'BSDXRESIEN ; Safeguard if index is corrupt
. . N BSDXRESNAM S BSDXRESNAM=$P(^BSDXRES(BSDXRESIEN,0),U)
. . S BSDXERR=BSDXERR_$C(13,10)_"Scheduling GUI clinic: "_BSDXRESNAM ; tell the user of the BSDX clinic
Q 0
;
UNMAKE(BSDR) ; Reverse Make - Private $$
; Only used in Emergiencies where Fileman data filing fails.
; If previous data exists, which caused an error, it's destroyed.
; NB: ^DIK stops for nobody
; NB: If Patient Appointment previously existed as cancelled, it's removed.
; How can I tell if one previously existed when data is in an intermediate
; State? Can I restore it if the other file failed? Restoration can cause
; another error. If I restore the global, there will be cross-references
; missing (ASDCN specifically).
;
; Input: Same array as $$MAKE
; Output: Always 0
NEW DIK,DA
S DIK="^DPT("_BSDR("PAT")_",""S"","
S DA(1)=BSDR("PAT"),DA=BSDR("ADT")
D ^DIK
;
N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
I 'IEN QUIT 0
;
NEW DIK,DA
S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
D ^DIK
QUIT 0
;
CHECKIN1(DFN,CLIN,APDATE) ; Simplified PEP w/ parameters for $$CHECKIN - Checking in
; Call like this for DFN 23435 checking in now at Hospital Location 33
; for appt at Dec 20, 2009 @ 10:11:59
; S RESULT=$$CHECKIN1^BSDXAPI(23435,33,3091220.221159)
N BSDR
S BSDR("PAT")=DFN ;DFN
S BSDR("CLN")=CLIN ;Hosp Loc IEN
S BSDR("ADT")=APDATE ;Appt Date
@ -203,70 +175,6 @@ CHECKIN(BSDR) ;EP; call to add checkin info to appt; IHS/ITSC/LJF 12/23/2004 PAT
; = 0 means everything worked
; = 1^message means error with reason message
;
I $G(BSDXDIE2) N X S X=1/0
;
N BSDXERR S BSDXERR=$$CHECKICK(.BSDR)
I BSDXERR Q BSDXERR
;
; find ien for appt in file 44
NEW IEN,DIE,DA,DR
S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
;
; remember before status
; Failure analysis: Only ^TMP global is set here.
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL,SDMODE
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; set checkin; Old Code -- keep for ref VEN/SMH 3 Jul 2012
; S DIE="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
; S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
; S DR="309///"_BSDR("CDT")_";302///`"_BSDR("USR")_";305///"_$$NOW^XLFDT
; D ^DIE
;
I $D(BSDXSIMERR3) Q 1_U_"Simulated Error"
;
; Failure analysis: If this fails, no other changes were made in this routine
N BSDXIENS S BSDXIENS=IEN_","_BSDR("ADT")_","_BSDR("CLN")_","
N BSDXFDA
S BSDXFDA(44.003,BSDXIENS,309)=BSDR("CDT")
S BSDXFDA(44.003,BSDXIENS,302)=BSDR("USR")
S BSDXFDA(44.003,BSDXIENS,305)=$$NOW^XLFDT()
N BSDXERR
D UPDATE^DIE("","BSDXFDA","BSDXERR")
;
I $D(BSDXERR) Q 1_U_"Error checking in appointment to file 44. Error: "_BSDXERR("DIERR",1,"TEXT",1)
;
; set after status
S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; Point of no Return
; call event driver
D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
Q 0
;
CHECKIC1(DFN,CLIN,APDATE) ; Simplified PEP w/ parameters for $$CHECKICK -
; Check-in Check
; Call like this for DFN 23435 checking in now at Hospital Location 33
; for appt at Dec 20, 2009 @ 10:11:59
; S RESULT=$$CHECKIC1^BSDXAPI(23435,33,3091220.221159)
N BSDR
S BSDR("PAT")=DFN ;DFN
S BSDR("CLN")=CLIN ;Hosp Loc IEN
S BSDR("ADT")=APDATE ;Appt Date
S BSDR("CDT")=$$NOW^XLFDT ;Check-in date defaults to now
S BSDR("USR")=DUZ ;Check-in user defaults to current
Q $$CHECKICK(.BSDR)
;
CHECKICK(BSDR) ; $$ PEP; - Is it okay to check-in patient?
; Input: Same as $$CHECKIN
; Output: 0 if okay or 1^message if error
;
I $G(BSDXSIMERR2) Q 1_U_"Simulated Error"
;
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12) ;remove seconds
@ -276,8 +184,29 @@ CHECKICK(BSDR) ; $$ PEP; - Is it okay to check-in patient?
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
;
; find ien for appt in file 44
N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
NEW IEN,DIE,DA,DR
S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
I 'IEN Q 1_U_"Error trying to find appointment for checkin: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
;
; remember before status
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; set checkin
S DIE="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
S DR="309///"_BSDR("CDT")_";302///`"_BSDR("USR")_";305///"_$$NOW^XLFDT
D ^DIE
;
; set after status
S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; call event driver
D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
Q 0
;
CANCEL1(DFN,CLIN,TYP,APDATE,REASON,INFO) ; PEP w/ parameters for $$CANCEL - cancelling appointment
@ -286,7 +215,6 @@ CANCEL1(DFN,CLIN,TYP,APDATE,REASON,INFO) ; PEP w/ parameters for $$CANCEL - canc
; cancelling appt at Dec 20, 2009 @ 10:11:59 because of reason 1 in file 409.2 IEN (weather)
; because foxes come out during bad weather.
; S RESULT=$$CANCEL1^BSDXAPI(23435,33,"PC",3091220.221159,1,"Afraid of foxes")
N BSDR
S BSDR("PAT")=DFN
S BSDR("CLN")=CLIN
S BSDR("TYP")=TYP
@ -315,70 +243,6 @@ CANCEL(BSDR) ;PEP; called to cancel appt
; = 0 or null: everything okay
; = 1^message: error and reason
;
; Okay to Cancel? Call Cancel Check.
N BSDXCANCK S BSDXCANCK=$$CANCELCK(.BSDR)
I BSDXCANCK Q BSDXCANCK
;
; BSDX 1.5 3110125
; UJO/SMH - Add ability to remove check-in if the patient is checked in
; VEN/SMH on 3120625/v1.7 - PIMS doesn't care if patient is already checked in
; Lets you remove appointment anyways! Not like RPMS.
; Plus... deleting checkin affects S node on 44, which is DELETED anyways!
;
; remember before status
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL,SDMODE
NEW IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
; NB: Here only ^TMP globals are set with before values.
;
; get user who made appt and date appt made from ^SC
; because data in ^SC will be deleted
; Appointment Length: ditto
NEW USER,DATE
S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
N BSDXLEN S BSDXLEN=$$APPLEN(DFN,SDCL,SDT) ; appt length
;
; update file 2 info --old code; keep for reference
;NEW DIE,DA,DR
;S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT
;S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
;S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)
;D ^DIE
N BSDXIENS S BSDXIENS=SDT_","_DFN_","
N BSDXFDA
S BSDXFDA(2.98,BSDXIENS,3)=BSDR("TYP")
S BSDXFDA(2.98,BSDXIENS,14)=BSDR("USR")
S BSDXFDA(2.98,BSDXIENS,15)=BSDR("CDT")
S BSDXFDA(2.98,BSDXIENS,16)=BSDR("CR")
S BSDXFDA(2.98,BSDXIENS,19)=USER
S BSDXFDA(2.98,BSDXIENS,20)=DATE
S:$G(BSDR("NOT"))]"" BSDXFDA(2.98,BSDXIENS,17)=$E(BSDR("NOT"),1,160)
N BSDXERR
D FILE^DIE("","BSDXFDA","BSDXERR")
I $D(BSDXERR) Q 1_U_"Cannot cancel appointment in File 2"
; Failure point 1: If we fail here, nothing has happened yet.
;
; delete data in ^SC -- this does not (typically) fail. Fileman won't stop
NEW DIK,DA
S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
D ^DIK
; Failure point 2: not expected to happen here
;
; Update PIMS availability -- this doesn't fail. Global gets/sets only.
D AVUPDTCN^BSDXAPI1(SDCL,SDT,BSDXLEN)
;
; call event driver -- point of no return
D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
;
Q 0
;
CANCELCK(BSDR) ; $$ PEP; Okay to Cancel Appointment?
; Input: .BSDR array as documented in $$CANCEL
; Output: 0 or 1^Error message
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I ($G(BSDR("TYP"))'="C"),($G(BSDR("TYP"))'="PC") Q 1_U_"Cancel Status error: "_$G(BSDR("TYP"))
@ -389,11 +253,45 @@ CANCELCK(BSDR) ; $$ PEP; Okay to Cancel Appointment?
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))
I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))
;
NEW IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
NEW IEN,DIE,DA,DR
S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
;
; Check-out check. New in v1.7
I $$CO(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Cannot delete. Appointment has already been checked-out!"
; BSDX 1.5 3110125
; UJO/SMH - Add ability to remove check-in if the patient is checked in
; I $$CI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
; Remove check-in if the patient is checked in.
N BSDXRESULT S BSDXRESULT=0 ; Result; should be zero if success; -1 + message if failure
I $$CI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) SET BSDXRESULT=$$RMCI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
I BSDXRESULT Q BSDXRESULT
;
; remember before status
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
;
; get user who made appt and date appt made from ^SC
; because data in ^SC will be deleted
NEW USER,DATE
S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
;
; update file 2 info
NEW DIE,DA,DR
S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT
S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)
D ^DIE
;
; delete data in ^SC
NEW DIK,DA
S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
D ^DIK
;
; call event driver
D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
Q 0
;
CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
@ -403,12 +301,44 @@ CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U)
Q $S(X:1,1:0)
;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
Q $S(X:1,1:0)
RMCI(PAT,CLINIC,DATE) ;PEP; -- Remove Check-in; $$
; PAT = DFN
; CLINIC = SC IEN
; DATE = FM Date/Time of Appointment
;
; Returns:
; 0 if okay
; -1 if failure
;
; Call like this: $$RMCI(233,33,3110102.1130)
;
; Move my variables into the ones used by SDAPIs (just a convenience)
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL
S DFN=PAT,SDT=DATE,SDCL=CLINIC,SDMODE=2,SDDA=$$SCIEN(DFN,SDCL,SDT)
;
I SDDA<1 QUIT 0 ; Appt cancelled; cancelled appts rm'ed from file 44
;
; remember before status
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; remove check-in using filer.
N BSDXIENS S BSDXIENS=SDDA_","_DATE_","_CLINIC_","
S BSDXFDA(44.003,BSDXIENS,309)="@" ; CHECKED-IN
S BSDXFDA(44.003,BSDXIENS,302)="@" ; CHECK IN USER
S BSDXFDA(44.003,BSDXIENS,305)="@" ; CHECK IN ENTERED
N BSDXERR
D FILE^DIE("","BSDXFDA","BSDXERR")
I $D(BSDXERR) QUIT "-1~Can't file for Pat "_PAT_" in Clinic "_CLINIC_" at "_DATE_". Fileman reported an error: "_BSDXERR("DIERR",1,"TEXT",1)
;
; set after status
S SDDA=$$SCIEN(DFN,SDCL,SDT)
S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
;
; call event driver
D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
QUIT 0
;
SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
NEW X,IEN
@ -417,12 +347,30 @@ SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
. I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
Q $G(IEN)
;
APPLEN(PAT,CLINIC,DATE) ; $$ PEP; returns an appointment's length
; Get either the appointment length or zero
N SCIEN S SCIEN=$$SCIEN(PAT,CLINIC,DATE)
Q:SCIEN $P(^SC(CLINIC,"S",DATE,1,SCIEN,0),U,2)
Q 0
APPTYP(PAT,DATE) ;PEP; -- returns type of appt (scheduled or walk-in)
NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
Q $S(X:1,1:0)
;
UPDATENOTE(PAT,CLINIC,DATE,NOTE) ; PEP; Update Note in ^SC for patient's appointment @ DATE
; PAT = DFN
; CLINIC = SC IEN
; DATE = FM Date/Time of Appointment
;
; Returns:
; 0 if okay
; -1 if failure
N SCIEN S SCIEN=$$SCIEN(PAT,CLINIC,DATE) ; ien of appt in ^SC
I SCIEN<1 QUIT 0 ; Appt cancelled; cancelled appts rm'ed from file 44
N BSDXIENS S BSDXIENS=SCIEN_","_DATE_","_CLINIC_","
S BSDXFDA(44.003,BSDXIENS,3)=$E(NOTE,1,150)
N BSDXERR
D FILE^DIE("","BSDXFDA","BSDXERR")
I $D(BSDXERR) QUIT "-1~Can't file for Pat "_PAT_" in Clinic "_CLINIC_" at "_DATE_". Fileman reported an error: "_BSDXERR("DIERR",1,"TEXT",1)
QUIT 0

2
m/BSDXAPI1.m
View File

@ -1,5 +1,5 @@
BSDXAPI1 ; VEN/SMH - SCHEDULING APIs - Continued!!! ; 7/9/12 2:22pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.7;BSDX;;Oct 04, 2012;Build 25
; Licensed under LGPL
;
; Change History (BSDXAPI and BSDXAPI1)

6
m/BSDXGPRV.m
View File

@ -1,5 +1,5 @@
BSDXGPRV ; WV/SMH - WINDOWS SCHEDULING RPCS ; 7/6/12 11:07am
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
BSDXGPRV ; WV/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:31am
;;1.6;BSDX;;Aug 31, 2011;Build 25
; Licensed under LGPL
;
;
@ -17,7 +17,7 @@ ERR(BSDXERR) ;Error processing
;
PD(BSDXY,HLIEN) ;EP Debugging entry point
;
;D DEBUG^%Serenji("P^BSDXGPRV(.BSDXY,HLIEN)","192.168.254.130")
D DEBUG^%Serenji("P^BSDXGPRV(.BSDXY,HLIEN)","192.168.254.130")
;
Q
;

2
m/BSDXUT.m
View File

@ -1,5 +1,5 @@
BSDXUT ; VEN/SMH - Unit Tests for Scheduling GUI ; 6/29/12 12:20pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.7;BSDX;;Oct 04, 2012;Build 25
; Licensed under LGPL
;
; Change Log:

2
m/BSDXUT1.m
View File

@ -1,5 +1,5 @@
BSDXUT1 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/9/12 12:31pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.7;BSDX;;Oct 04, 2012;Build 25
;
;
EN ; Run All Unit Tests in this routine

2
m/BSDXUT2.m
View File

@ -1,5 +1,5 @@
BSDXUT2 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/9/12 3:18pm
;;1.7T2;BSDX;;Jul 11, 2012;Build 18
;;1.7;BSDX;;Oct 04, 2012;Build 25
;
EN ; Run all unit tests in this routine
D UT25,PIMS