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

Updated routines version to 1.42

This commit is contained in:
sam 2010-12-12 16:11:57 +00:00
parent ea124e92c1
commit 67dd7ba3af
37 changed files with 1293 additions and 1242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
m/BSDX01.m
View File

@ -1,5 +1,5 @@
BSDX01 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 9/29/10 10:20am
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
SUINFOD(BSDXY,BSDXDUZ) ;EP Debugging entry point
;D DEBUG^%Serenji("SUINFO^BSDX01(.BSDXY,BSDXDUZ)")

2
m/BSDX02.m
View File

@ -1,5 +1,5 @@
BSDX02 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:25pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log
; July 15 2010: UJO/SMH - Pass FM dates in instead of US dates for i18n

2
m/BSDX03.m
View File

@ -1,5 +1,5 @@
BSDX03 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
Q

2
m/BSDX04.m
View File

@ -1,5 +1,5 @@
BSDX04 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 7/15/10 12:44pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
; Change Log:
; July 11 2010: Pass BSDXSTART and END as FM dates rather than US formatted dates
; for i18n

127
m/BSDX05.m
View File

@ -1,63 +1,68 @@
BSDX05 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:51pm
;;1.41;BSDX;;Sep 29, 2010
;
BSDX05 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 5:36pm
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; UJO/SMH - July 11 2010: pass FM Dates for Start and End rather than US Dates
;
APBLKOV(BSDXY,BSDXSTART,BSDXEND,BSDXRES) ;EP
;Called by BSDX APPT BLOCKS OVERLAP
; July 11 2010 - pass FM Dates for Start and End rather than US Dates
;(Duplicates old qryAppointmentBlocksOverlapB)
;BSDXRES is resource name
;
;Test lines:
;D APBLKOV^BSDX05(.RES,"11-8-2000","11-8-2004","WHITT") ZW RES
;BSDX APPT BLOCKS OVERLAP^11-8-2000^11-8-2004^WHITT
;S ^HW("BSDXD05")=BSDXSTART_U_BSDXEND_U_BSDXRES
;
N BSDXERR,BSDXIEN,BSDXDEP,BSDXBS,BSDXI,BSDXNEND,BSDXNSTART,BSDXPEND,BSDXRESD,BSDXRESN,BSDXS,BSDXAD,BSDXNOD
K ^BSDXTMP($J)
S BSDXERR=""
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="D00030START_TIME^D00030END_TIME"_$C(30)
D
. S BSDXBS=0
. S BSDXEND=BSDXEND+.9999 ;Go to end of day
. S BSDXRESN=BSDXRES
. Q:BSDXRESN=""
. Q:'$D(^BSDXRES("B",BSDXRESN))
. S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0))
. Q:'+BSDXRESD
. Q:'$D(^BSDXAPPT("ARSRC",BSDXRESD))
. D STRES(BSDXRESD,BSDXSTART,BSDXEND)
. Q
;
S BSDXI=$G(BSDXI)+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
STRES(BSDXRESD,BSDXSTART,BSDXEND) ;
;$O THRU "ARSRC" XREF OF ^BSDXAPPT
;Start at the beginning of the day -- appts can't overlap days
S BSDXS=$P(BSDXSTART,"."),BSDXS=BSDXS-.0001
S BSDXI=0
F S BSDXS=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS)) Q:'+BSDXS Q:BSDXS>BSDXEND D
. S BSDXAD=0 F S BSDXAD=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS,BSDXAD)) Q:'+BSDXAD D STCOMM(BSDXAD) ;BSDXAD Is the AppointmentID
. Q
Q
;
STCOMM(BSDXAD) ;
S BSDXNEND=0,BSDXNSTART=0,BSDXPEND=0
Q:'$D(^BSDXAPPT(BSDXAD,0))
S BSDXNOD=^BSDXAPPT(BSDXAD,0)
Q:$P(BSDXNOD,U,10)=1 ;NO-SHOW Flag
Q:$P(BSDXNOD,U,12)]"" ;CANCELLED APPT
Q:$P(BSDXNOD,U,13)="y" ;WALKIN
S BSDXNSTART=$P(BSDXNOD,U)
S BSDXNEND=$P(BSDXNOD,U,2)
I BSDXNEND'>BSDXSTART Q ;End is less than start
S Y=BSDXNSTART X ^DD("DD") S BSDXNSTART=$TR(Y,"@"," ")
S Y=BSDXNEND X ^DD("DD") S BSDXNEND=$TR(Y,"@"," ")
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXNSTART_U_BSDXNEND_$C(30)
Q
; UJO/SMH - Dec 8 2010: In STCOMM, the logic was that an appointment
; that was a walk-in didn't count towards slot calculations.
; I checked PIMS, and Walk-ins do indeed count towards slot calculations.
; Therefore, I commented this line out:
; ;Q:$P(BSDXNOD,U,13)="y" ;WALKIN
;
APBLKOV(BSDXY,BSDXSTART,BSDXEND,BSDXRES) ;EP
;Called by BSDX APPT BLOCKS OVERLAP
; July 11 2010 - pass FM Dates for Start and End rather than US Dates
;(Duplicates old qryAppointmentBlocksOverlapB)
;BSDXRES is resource name
;
;Test lines:
;D APBLKOV^BSDX05(.RES,"11-8-2000","11-8-2004","WHITT") ZW RES
;BSDX APPT BLOCKS OVERLAP^11-8-2000^11-8-2004^WHITT
;S ^HW("BSDXD05")=BSDXSTART_U_BSDXEND_U_BSDXRES
;
N BSDXERR,BSDXIEN,BSDXDEP,BSDXBS,BSDXI,BSDXNEND,BSDXNSTART,BSDXPEND,BSDXRESD,BSDXRESN,BSDXS,BSDXAD,BSDXNOD
K ^BSDXTMP($J)
S BSDXERR=""
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="D00030START_TIME^D00030END_TIME"_$C(30)
D
. S BSDXBS=0
. S BSDXEND=BSDXEND+.9999 ;Go to end of day
. S BSDXRESN=BSDXRES
. Q:BSDXRESN=""
. Q:'$D(^BSDXRES("B",BSDXRESN))
. S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0))
. Q:'+BSDXRESD
. Q:'$D(^BSDXAPPT("ARSRC",BSDXRESD))
. D STRES(BSDXRESD,BSDXSTART,BSDXEND)
. Q
;
S BSDXI=$G(BSDXI)+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
STRES(BSDXRESD,BSDXSTART,BSDXEND) ;
;$O THRU "ARSRC" XREF OF ^BSDXAPPT
;Start at the beginning of the day -- appts can't overlap days
S BSDXS=$P(BSDXSTART,"."),BSDXS=BSDXS-.0001
S BSDXI=0
F S BSDXS=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS)) Q:'+BSDXS Q:BSDXS>BSDXEND D
. S BSDXAD=0 F S BSDXAD=$O(^BSDXAPPT("ARSRC",BSDXRESD,BSDXS,BSDXAD)) Q:'+BSDXAD D STCOMM(BSDXAD) ;BSDXAD Is the AppointmentID
. Q
Q
;
STCOMM(BSDXAD) ;
S BSDXNEND=0,BSDXNSTART=0,BSDXPEND=0
Q:'$D(^BSDXAPPT(BSDXAD,0))
S BSDXNOD=^BSDXAPPT(BSDXAD,0)
Q:$P(BSDXNOD,U,10)=1 ;NO-SHOW Flag
Q:$P(BSDXNOD,U,12)]"" ;CANCELLED APPT
; Q:$P(BSDXNOD,U,13)="y" ;WALKIN -- new in V 1.42. See top comments.
S BSDXNSTART=$P(BSDXNOD,U)
S BSDXNEND=$P(BSDXNOD,U,2)
I BSDXNEND'>BSDXSTART Q ;End is less than start
S Y=BSDXNSTART X ^DD("DD") S BSDXNSTART=$TR(Y,"@"," ")
S Y=BSDXNEND X ^DD("DD") S BSDXNEND=$TR(Y,"@"," ")
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXNSTART_U_BSDXNEND_$C(30)
Q

2
m/BSDX06.m
View File

@ -1,5 +1,5 @@
BSDX06 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 4:51pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
; Change Log:
; UJO/SMH: July 15 2010: Change in BSDXSTART and BSDXEND: get
; dates in FM format for i18n

684
m/BSDX07.m
View File

@ -1,349 +1,349 @@
BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 10/31/10 9:38am
;;1.42;BSDX;;Sep 29, 2010
;
; 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.
;
; Error Reference:
; -1: Patient Record is locked. This means something is wrong!!!!
; -2: Start Time is not a valid Fileman date
; -3: End Time is not a valid Fileman date
; -4: End Time does not have time inside of it.
; -5: BSDXPATID is not numeric
; -6: Patient Does not exist in ^DPT
; -7: Resource Name does not exist in B index of BSDX RESOURCE
; -8: Resouce doesn't exist in ^BSDXRES
; -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)")
Q
;
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
;
BSDX07 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:31pm
;;1.42;BSDX;;Dec 07, 2010
;
; 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.
;
; Error Reference:
; -1: Patient Record is locked. This means something is wrong!!!!
; -2: Start Time is not a valid Fileman date
; -3: End Time is not a valid Fileman date
; -4: End Time does not have time inside of it.
; -5: BSDXPATID is not numeric
; -6: Patient Does not exist in ^DPT
; -7: Resource Name does not exist in B index of BSDX RESOURCE
; -8: Resouce doesn't exist in ^BSDXRES
; -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)")
Q
;
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) ;EP
;Called by RPC: BSDX ADD NEW APPOINTMENT
;
;Add new appointment to 3 files
; - BSDX APPOINTMENT
; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
; - Patient Appointment Subfile if Resource is linked to clinic
;
;Paramters:
;BSDXY: Global Return (RPC must be set to Global Array)
;BSDXSTART: FM Start Date
;BSDXEND: FM End Date
;BSDXPATID: Patient DFN
;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
;BSDXLEN is the appointment duration in minutes
;BSDXNOTE is the Appiontment Note
;BSDXATID is used for 2 purposes:
; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
; if BSDXATID = a number, then it is the access type id (used for rebooking)
;
;Return:
; ADO.net Recordset having fields:
; AppointmentID and ErrorNumber
;
;Test lines:
;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
;
; 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 +^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^T00020ERRORID"_$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
S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
;
; Set Error Message to be empty
N BSDXERR S BSDXERR=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 --
; If C# sends the dates with extra zeros, remove them
S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
; Are the dates valid? Must be FM Dates > than 2010
I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
; If Ending date doesn't have a time, this is an error
I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
; If the Start Date is greater than the end date, swap dates
N BSDXTMP
I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
;
; Check if the patient exists:
; - DFN valid number?
; - Valid Patient in file 2?
I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
;
;Validate Resource entry
I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
N BSDXRESD ; Resource IEN
S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
N BSDXRNOD ; Resouce zero node
S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
;
; Walk-in (Unscheduled) Appointment?
N BSDXWKIN S BSDXWKIN=0
I BSDXATID="WALKIN" S BSDXWKIN=1
; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
;
; Done with all checks, let's make appointment in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
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
; 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^BSDAPI 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
. S:BSDXWKIN BSDXC("TYP")=4
. S BSDXC("ADT")=BSDXSTART
. S BSDXC("LEN")=BSDXLEN
. S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
. 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=$$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
;Called by RPC: BSDX ADD NEW APPOINTMENT
;
;Add new appointment to 3 files
; - BSDX APPOINTMENT
; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
; - Patient Appointment Subfile if Resource is linked to clinic
;
;Paramters:
;BSDXY: Global Return (RPC must be set to Global Array)
;BSDXSTART: FM Start Date
;BSDXEND: FM End Date
;BSDXPATID: Patient DFN
;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
;BSDXLEN is the appointment duration in minutes
;BSDXNOTE is the Appiontment Note
;BSDXATID is used for 2 purposes:
; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
; if BSDXATID = a number, then it is the access type id (used for rebooking)
;
;Return:
; ADO.net Recordset having fields:
; AppointmentID and ErrorNumber
;
;Test lines:
;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
;
; 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 +^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
S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
;
; Set Error Message to be empty
N BSDXERR S BSDXERR=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 --
; If C# sends the dates with extra zeros, remove them
S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
; Are the dates valid? Must be FM Dates > than 2010
I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
; If Ending date doesn't have a time, this is an error
I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
; If the Start Date is greater than the end date, swap dates
N BSDXTMP
I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
;
; Check if the patient exists:
; - DFN valid number?
; - Valid Patient in file 2?
I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
;
;Validate Resource entry
I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
N BSDXRESD ; Resource IEN
S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
N BSDXRNOD ; Resouce zero node
S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
;
; Walk-in (Unscheduled) Appointment?
N BSDXWKIN S BSDXWKIN=0
I BSDXATID="WALKIN" S BSDXWKIN=1
; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
;
; Done with all checks, let's make appointment in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID)
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
; 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^BSDAPI 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
. S:BSDXWKIN BSDXC("TYP")=4
. S BSDXC("ADT")=BSDXSTART
. S BSDXC("LEN")=BSDXLEN
. S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
. 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=$$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)
Q BSDXZ
;
BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
;Returns ien in BSDXAPPT or 0 if failed
;Create entry in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
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
N BSDXIEN,BSDXMSG
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXAPPTID=+$G(BSDXIEN(1))
Q BSDXAPPTID
;
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)
Q BSDXZ
;
BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID) ;ADD BSDX APPOINTMENT ENTRY
;Returns ien in BSDXAPPT or 0 if failed
;Create entry in BSDX APPOINTMENT
N BSDXAPPTID
S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
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
N BSDXIEN,BSDXMSG
D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
S BSDXAPPTID=+$G(BSDXIEN(1))
Q BSDXAPPTID
;
BSDXWP(BSDXAPPTID,BSDXNOTE) ;
;Add WP field
I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
Q
;
;Add WP field
I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
Q
;
ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA) ;EP
;Called by BSDX ADD APPOINTMENT protocol
;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
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))
Q:'+$G(BSDXRES)
S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
Q:BSDXNOD=""
S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
S BSDXWKIN=""
S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
S BSDXLEN=$P(BSDXNOD,U,2)
Q:'+BSDXLEN
S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
Q:'+BSDXAPPTID
S BSDXNOTE=$P(BSDXNOD,U,4)
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
D ADDEVT3(BSDXRES)
Q
;
ADDEVT3(BSDXRES) ;
;Call RaiseEvent to notify GUI clients
N BSDXRESN
S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
Q:BSDXRESN=""
S BSDXRESN=$P(BSDXRESN,"^")
;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
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
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
;
;Called by BSDX ADD APPOINTMENT protocol
;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
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))
Q:'+$G(BSDXRES)
S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
Q:BSDXNOD=""
S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
S BSDXWKIN=""
S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
S BSDXLEN=$P(BSDXNOD,U,2)
Q:'+BSDXLEN
S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
Q:'+BSDXAPPTID
S BSDXNOTE=$P(BSDXNOD,U,4)
I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
D ADDEVT3(BSDXRES)
Q
;
ADDEVT3(BSDXRES) ;
;Call RaiseEvent to notify GUI clients
N BSDXRESN
S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
Q:BSDXRESN=""
S BSDXRESN=$P(BSDXRESN,"^")
;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
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
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
;
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
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
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

324
m/BSDX08.m
View File

@ -1,164 +1,164 @@
BSDX08 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 11/16/10 7:12am
;;1.42;BSDX;;Sep 29, 2010
;
; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
;
; Change History
; 3101022 UJO/SMH v1.42
; - 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.
;
; Error Reference:
; -1~BSDX08: Appt record is locked. Please contact technical support.
; -2~BSDX08: Invalid Appointment ID
BSDX08 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:35pm
;;1.42;BSDX;;Dec 07, 2010
;
; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
;
; Change History
; 3101022 UJO/SMH v1.42
; - 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.
;
; Error Reference:
; -1~BSDX08: Appt record is locked. Please contact technical support.
; -2~BSDX08: Invalid Appointment ID
; -3~BSDX08: Invalid Appointment ID
; -4~BSDX08: Cancelled appointment does not have a Resouce ID
; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE
; -6~BSDX08: Invalid Hosp Location stored in Database
; -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)
; -100~BSDX08 Error: (Mumps Error)
; -4~BSDX08: Cancelled appointment does not have a Resouce ID
; -5~BSDX08: Resouce ID does not exist in BSDX RESOURCE
; -6~BSDX08: Invalid Hosp Location stored in Database
; -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)
; -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)")
Q
;
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",!
QUIT
; Lock the node in another job for testing.
UTL(APPID) L +^BSDXAPPT(APPID) HANG 10 QUIT
;
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",!
QUIT
; Lock the node in another job for testing.
UTL(APPID) L +^BSDXAPPT(APPID) HANG 10 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:
;Input Parameters:
; - BSDXAPTID is entry number in BSDX APPOINTMENT file
; - BSDXTYP is C for clinic-cancelled and PC for patient cancelled
; - BSDXCR is pointer to CANCELLATION REASON File (409.2)
; - BSDXNOT is user note
;
; Returns error code in recordset field ERRORID. Zero is success.
; Returns Global Array. Must use this type in RPC.
; Returns error code in recordset field ERRORID. Zero is success.
; Returns Global Array. Must use this type in RPC.
;
; Return Array: set Return and clear array
; Return Array: set Return and clear array
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
K ^BSDXTMP($J)
;
; Set min DUZ vars if they don't exist
D ^XBKVAR
;
; $ET
N $ET S $ET="G ETRAP^BSDX08"
; Set min DUZ vars if they don't exist
D ^XBKVAR
;
; $ET
N $ET S $ET="G ETRAP^BSDX08"
;
; Counter
; Counter
N BSDXI S BSDXI=0
; Header Node
S ^BSDXTMP($J,BSDXI)="T00030ERRORID"_$C(30)
; 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
; 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"
;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
; 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(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
;;;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
;
; 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
;
; Start Processing:
; First, add cancellation date to appt entry in BSDX APPOINTMENT
; 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
;
; Second, cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
; 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 resouce 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
I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
; Get zero node of resouce
S BSDXNOD=^BSDXRES(BSDXSC1,0)
; Get Hosp location
S BSDXNOD=^BSDXRES(BSDXSC1,0)
; Get Hosp location
N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
; 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
; 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
. ; 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
. 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))
. 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
. 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)
;
@ -173,46 +173,46 @@ APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
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 (SD,S)=BSDXSTART
N I ; Clinic IEN in 44
S I=BSDXSCD
; if day has no schedule in legacy PIMS, forget about this update.
; 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)
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)
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 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
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
;
@ -295,23 +295,23 @@ ERR(BSDXI,BSDXERR) ;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
; Rollback, otherwise ^XTER will be empty from future rollback
I $TL>0 TROLLBACK
D ^%ZTER
S $EC="" ; Clear Error
; Log error message and send to client
I '$D(BSDXI) N BSDXI S BSDXI=0
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
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
; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
;
;;;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
; I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
; . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
; . S BSDXZ=1
; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit
; . ; Check if there are associated RPMS clinics. (not currently used) Does the multiple exist? No, then quit
; . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 QUIT
; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN.
; . ; Loop through the multiple. Get Location and then the ^SC "S" node IEN.
; . N BSDX1 S BSDX1=0
; . F S BSDX1=$O(^BSDXRES(BSDXSC1,20,BSDX1)) Q:'+BSDX1 Q:BSDXZ=0 D
; . . Q:'$D(^BSDXRES(BSDXSC1,20,BSDX1,0))

6
m/BSDX09.m
View File

@ -1,5 +1,5 @@
BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 10/20/10 4:16pm
;;1.41;BSDX;;Sep 07, 2010;Build 7
;;1.42;BSDX;;Dec 07, 2010;Build 7
;
; Change Log:
; UJO/TH - v 1.3 on 3100714 - Extra Demographics:
@ -10,8 +10,8 @@ BSDX09 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; ; 10/20/10 4:16pm
;
; UJO/TH - v 1.3 on 3100715 - Change SSN to PID and get PID field instead
;
; UJO/TH - v 1.42 on 3101020 - Add Sex field.
;
; UJO/TH - v 1.42 on 3101020 - Add Sex field.
;
GETREGA(BSDXRET,BSDXPAT) ;EP
;
; See below for the returned fields

2
m/BSDX11.m
View File

@ -1,5 +1,5 @@
BSDX11 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
ENV0100 ;EP Version 1.0 Environment check
I '$G(IOM) D HOME^%ZIS

2
m/BSDX12.m
View File

@ -1,5 +1,5 @@
BSDX12 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:14pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; v 1.3 - i18n support - 3100718

8
m/BSDX13.m
View File

@ -1,5 +1,5 @@
BSDX13 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:17pm
;;1.41;BSDX;;Sep 29, 2010
BSDX13 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 6:05pm
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; V 1.3 - i18n support - Dates passed to Routine as FM Date - WV/SMH
@ -30,7 +30,7 @@ AVDELDT(BSDXY,BSDXRESD,BSDXSTART,BSDXEND) ;EP
; S X=BSDXEND
; S %DT="X" D ^%DT
; I Y=-1 D ERR(0,"AVDELDT-BSDX13: Invalid End Date") Q
S BSDXEND=$P(Y,".")_".99999"
S BSDXEND=$P(BSDXEND,".")_".99999"
I '+BSDXRESD D ERR(0,"AVDELDT-BSDX13: Invalid Resource ID") Q
;
F S BSDXSTART=$O(^BSDXAB("ARSCT",BSDXRESD,BSDXSTART)) Q:'+BSDXSTART Q:BSDXSTART>BSDXEND D
@ -45,7 +45,7 @@ ERROR ;
D ^%ZTER
I '+$G(BSDXI) N BSDXI S BSDXI=999999
S BSDXI=BSDXI+1
D ERR(0,"BSDX13 M Error: <"_$G(%ZTERROR)_">")
D ERR(0,"BSDX13 M Error: <"_$G(%ZTERZE)_">")
Q
;
ERR(BSDXERID,ERRTXT) ;Error processing

2
m/BSDX14.m
View File

@ -1,5 +1,5 @@
BSDX14 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
ACCTYPD(BSDXY,BSDXVAL) ;EP

2
m/BSDX15.m
View File

@ -1,5 +1,5 @@
BSDX15 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
GRPTYP(BSDXY) ;EP

2
m/BSDX16.m
View File

@ -1,5 +1,5 @@
BSDX16 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
RSRCD(BSDXY,BSDXVAL) ;EP

2
m/BSDX17.m
View File

@ -1,5 +1,5 @@
BSDX17 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
SCHUSRD(BSDXY) ;EP

2
m/BSDX18.m
View File

@ -1,5 +1,5 @@
BSDX18 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
DELRUD(BSDXY,BSDXIEN) ;EP

2
m/BSDX19.m
View File

@ -1,5 +1,5 @@
BSDX19 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
ADDRGD(BSDXY,BSDXVAL) ;EP

2
m/BSDX20.m
View File

@ -1,5 +1,5 @@
BSDX20 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
DELRGID(BSDXY,BSDXIEN) ;EP

2
m/BSDX21.m
View File

@ -1,5 +1,5 @@
BSDX21 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/21/10 9:42pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
ADDAGD(BSDXY,BSDXVAL) ;EP

2
m/BSDX22.m
View File

@ -1,5 +1,5 @@
BSDX22 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
DELAGID(BSDXY,BSDXIEN,BSDXIEN1) ;EP

2
m/BSDX23.m
View File

@ -1,5 +1,5 @@
BSDX23 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
EVENT(BSDXEVENT,BSDXPARAM,BSDXSIP,BSDXSPT) ;EP

2
m/BSDX24.m
View File

@ -1,5 +1,5 @@
BSDX24 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
Q

2
m/BSDX25.m
View File

@ -1,5 +1,5 @@
BSDX25 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP

264
m/BSDX26.m
View File

@ -1,132 +1,132 @@
BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 3:08am
;;1.42;BSDX;;Sep 29, 2010
; Change History:
; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx.
; --> Thanks to Zach Gonzalez and Rick Marshall
; 3101205 - UJO/SMH - Extensive refactoring.
;
; 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
;
EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE) ;EP
;Entry point for debugging
;
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
;
; Edits Appointment Text in BSDX APPOINTMENT file & Hosp Location (44) file
;
; Parameters:
; - BSDXY: Global Return (RPC must be set to Global Array)
; - BSDXAPTID: Appointment IEN in BSDX APPOINTMENT
; - BSDXNOTE: New note
;
; Return:
; ADO.net Recordset having 1 field: ERRORID
; If Okay: -1; otherwise, positive integer with message
;
; Return Array; set Return and clear array
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
; ET
N $ET S $ET="G ETRAP^BSDX26"
; Set up basic DUZ variables
D ^XBKVAR
; Counter
N BSDXI S BSDXI=0
; Header Node
S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$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 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
; 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.
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG")
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
N HLIEN S HLIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".07:.04","I") ; HL Location IEN pointed to by Resource ID
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=$$UPDATENOTE^BSDXAPI(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
; If we get an error (denoted by -1 in BSDXRES), return error to client
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)
QUIT
;
ERR(BSDXI,BSDXERR) ;Error processing
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)
QUIT
;
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))
Q
BSDX26 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:38pm
;;1.42;BSDX;;Dec 07, 2010
; Change History:
; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx.
; --> Thanks to Zach Gonzalez and Rick Marshall
; 3101205 - UJO/SMH - Extensive refactoring.
;
; 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
;
EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE) ;EP
;Entry point for debugging
;
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
;
; Edits Appointment Text in BSDX APPOINTMENT file & Hosp Location (44) file
;
; Parameters:
; - BSDXY: Global Return (RPC must be set to Global Array)
; - BSDXAPTID: Appointment IEN in BSDX APPOINTMENT
; - BSDXNOTE: New note
;
; Return:
; ADO.net Recordset having 1 field: ERRORID
; If Okay: -1; otherwise, positive integer with message
;
; Return Array; set Return and clear array
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
; ET
N $ET S $ET="G ETRAP^BSDX26"
; Set up basic DUZ variables
D ^XBKVAR
; Counter
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 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
; 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.
I $D(BSDXNOTE(.5)) D
. D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG")
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
N HLIEN S HLIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".07:.04","I") ; HL Location IEN pointed to by Resource ID
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=$$UPDATENOTE^BSDXAPI(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
; If we get an error (denoted by -1 in BSDXRES), return error to client
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)
QUIT
;
ERR(BSDXI,BSDXERR) ;Error processing
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)
QUIT
;
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))
Q

510
m/BSDX27.m
View File

@ -1,250 +1,266 @@
BSDX27 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:22pm
;;1.41;BSDX;;Sep 29, 2010
BSDX27 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 4:52pm
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log: July 15, 2010
; UJO/SMH - i18n: FM Dates passed into routine for Clinic Letters - CLDISP tag
;
;
Q
;
PADISPD(BSDXY,BSDXPAT) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("PADISP^BSDX27(.BSDXY,BSDXPAT)")
Q
;
PADISP(BSDXY,BSDXPAT) ;EP
;Return recordset of patient appointments used in listing
;a patient's appointments and generating patient letters.
;Called by rpc BSDX PATIENT APPT DISPLAY
;
N BSDXI,BSDXIEN,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCNID,BSDXCNOD,BSDXMADE,BSDXCLRK,BSDXNOT,BSDXQ
N BSDXSTRT
N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXY="^BSDXTMP("_$J_")"
S BSDXI=0
S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus"
S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30)
S X="ERROR^BSDX27",@^%ZOSF("TRAP")
;Get patient info
;
I '+BSDXPAT S ^BSDXTMP($J,1)=$C(31) Q
I '$D(^DPT(+BSDXPAT,0)) S ^BSDXTMP($J,1)=$C(31) Q
S BSDXNOD=$$PATINFO(BSDXPAT)
S BSDXNAM=$P(BSDXNOD,U) ;NAME
S BSDXSEX=$P(BSDXNOD,U,2) ;SEX
S BSDXDOB=$P(BSDXNOD,U,3) ;DOB
S BSDXHRN=$P(BSDXNOD,U,4) ;Health Record Number for location DUZ(2)
S BSDXSTRE=$P(BSDXNOD,U,5) ;Street
S BSDXCITY=$P(BSDXNOD,U,6) ;City
S BSDXST=$P(BSDXNOD,U,7) ;State
S BSDXZIP=$P(BSDXNOD,U,8) ;zip
S BSDXPHON=$P(BSDXNOD,U,9) ;homephone
;
;Organize ^DPT(BSDXPAT,"S," nodes
; into BSDXDPT(CLINIC,DATE)
;
I $D(^DPT(BSDXPAT,"S")) S BSDXDT=0 F S BSDXDT=$O(^DPT(BSDXPAT,"S",BSDXDT)) Q:'+BSDXDT D
. S BSDXNOD=$G(^DPT(BSDXPAT,"S",BSDXDT,0))
. S BSDXCID=$P(BSDXNOD,U)
. Q:'+BSDXCID
. Q:'$D(^SC(BSDXCID,0))
. S BSDXDPT(BSDXCID,BSDXDT)=BSDXNOD
;
;$O Through ^BSDX("CPAT",
S BSDXIEN=0
I $D(^BSDXAPPT("CPAT",BSDXPAT)) F S BSDXIEN=$O(^BSDXAPPT("CPAT",BSDXPAT,BSDXIEN)) Q:'BSDXIEN D
. N BSDXNOD,BSDXAPT,BSDXCID,BSDXCNOD,BSDXCLN,BSDX44,BSDXDNOD,BSDXSTAT,BSDX,BSDXTYPE,BSDXLIN
. S BSDXNOD=$G(^BSDXAPPT(BSDXIEN,0))
. Q:BSDXNOD=""
. Q:$P(BSDXNOD,U,12)]"" ;CANCELLED
. S Y=$P(BSDXNOD,U)
. Q:'+Y
. X ^DD("DD") S Y=$TR(Y,"@"," ")
. S BSDXAPT=Y ;Appointment date time
. S BSDXCLRK=$P(BSDXNOD,U,8) ;Appointment made by
. S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. S Y=$P(BSDXNOD,U,9) ;Date Appointment Made
. I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. S BSDXMADE=Y
. ;NOTE
. S BSDXNOT=""
. I $D(^BSDXAPPT(BSDXIEN,1,0)) S BSDXNOT="",BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXIEN,1,BSDXQ)) Q:'+BSDXQ D
. . S BSDXLIN=$G(^BSDXAPPT(BSDXIEN,1,BSDXQ,0))
. . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" "
. . S BSDXNOT=BSDXNOT_BSDXLIN
. ;Resource
. S BSDXCID=$P(BSDXNOD,U,7) ;IEN of BSDX RESOURCE
. Q:'+BSDXCID
. Q:'$D(^BSDXRES(BSDXCID,0))
. S BSDXCNOD=$G(^BSDXRES(BSDXCID,0)) ;BSDX RESOURCE node
. Q:BSDXCNOD=""
. S BSDXCLN=$P(BSDXCNOD,U) ;Text name of BSDX Resource
. S BSDX44=$P(BSDXCNOD,U,4) ;File 44 pointer
. ;If appt entry in ^DPT(PAT,"S" exists for this clinic, get the TYPE/STATUS info from
. ;the BSDXDPT array and delete the BSDXDPT node
. S BSDXTYPE=""
. I +BSDX44,$D(BSDXDPT(BSDX44,$P(BSDXNOD,U))) D ;BSDXNOD is the BSDX APPOINTMENT node
. . S BSDXDNOD=BSDXDPT(BSDX44,$P(BSDXNOD,U)) ;BSDXDNOD is a copy of the ^DPT(PAT,"S" node
. . S BSDXTYPE=$$STATUS(BSDXPAT,$P(BSDXNOD,U),BSDXDNOD) ;IHS/OIT/HMW 20050208 Added
. . K BSDXDPT(BSDX44,$P(BSDXNOD,U))
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
. Q
;
;Go through remaining BSDXDPT( entries
I $D(BSDXDPT) S BSDX44=0 D
. F S BSDX44=$O(BSDXDPT(BSDX44)) Q:'+BSDX44 S BSDXDT=0 D
. . F S BSDXDT=$O(BSDXDPT(BSDX44,BSDXDT)) Q:'+BSDXDT D
. . . S BSDXDNOD=BSDXDPT(BSDX44,BSDXDT)
. . . S Y=BSDXDT
. . . Q:'+Y
. . . X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXAPT=Y
. . . S BSDXTYPE=$$STATUS(BSDXPAT,BSDXDT,BSDXDNOD) ;IHS/OIT/HMW 20050208 Added
. . . S BSDXCLN=$P($G(^SC(BSDX44,0)),U)
. . . S BSDXCLRK=$P(BSDXDNOD,U,18)
. . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. . . S Y=$P(BSDXDNOD,U,19)
. . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXMADE=Y
. . . S BSDXNOT=""
. . . S BSDXI=BSDXI+1
. . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
. . . K BSDXDPT(BSDX44,BSDXDT)
;
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
STATUS(PAT,DATE,NODE) ; returns appt status
;IHS/OIT/HMW 20050208 Added from BSDDPA
NEW TYP
S TYP=$$APPTYP^BSDXAPI(PAT,DATE) ;sched vs. walkin
I $P(NODE,U,2)["C" Q TYP_" - CANCELLED"
I $P(NODE,U,2)'="NT",$P(NODE,U,2)["N" Q TYP_" - NO SHOW"
I $$CO^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED OUT"
I $$CI^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED IN"
Q TYP
;
ERROR ;
D ERR(BSDXI,"RPMS Error")
Q
;
ERR(BSDXI,ERRNO,MSG) ;Error processing
S:'$D(BSDXI) BSDXI=999
I +ERRNO S BSDXERR=ERRNO+134234112 ;vbObjectError
E S BSDXERR=ERRNO
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=MSG_"^^^^^^^^^^^^^^^"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
PATINFO(BSDXPAT) ;EP
;Intrisic Function returns NAME^SEX^DOB^HRN^STREET^CITY^STATE^ZIP^PHONE for patient ien BSDXPAT
;DOB is in external format
;HRN depends on existence of DUZ(2)
;
N BSDXNOD,BSDXNAM,BSDXSEX,BSDXDOB,BSDXHRN,BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXNOD=^DPT(+BSDXPAT,0)
S BSDXNAM=$P(BSDXNOD,U) ;NAME
S BSDXSEX=$P(BSDXNOD,U,2)
S BSDXSEX=$S(BSDXSEX="F":"FEMALE",BSDXSEX="M":"MALE",1:"")
S Y=$P(BSDXNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ")
S BSDXDOB=Y ;DOB
S BSDXHRN=""
I $D(DUZ(2)) I DUZ(2)>0 S BSDXHRN=$P($G(^AUPNPAT(BSDXPAT,41,DUZ(2),0)),U,2) ;HRN
;
S BSDXNOD=$G(^DPT(+BSDXPAT,.11))
S (BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP)=""
I BSDXNOD]"" D
. S BSDXSTRT=$E($P(BSDXNOD,U),1,50) ;STREET
. S BSDXCITY=$P(BSDXNOD,U,4) ;CITY
. S BSDXST=$P(BSDXNOD,U,5) ;STATE
. I +BSDXST,$D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2)
. S BSDXZIP=$P(BSDXNOD,U,6) ;ZIP
;
S BSDXNOD=$G(^DPT(+BSDXPAT,.13)) ;PHONE
S BSDXPHON=$P(BSDXNOD,U)
;
Q BSDXNAM_U_BSDXSEX_U_BSDXDOB_U_BSDXHRN_U_BSDXSTRT_U_BSDXCITY_U_BSDXST_U_BSDXZIP_U_BSDXPHON
;
; UJO/SMH - i18n: FM Dates passed into routine for Clinic Letters - CLDISP ta
; v 1.42 - 3101208 - SMH
; - Added check to skip cancelled appointments. Check was forgotten
; in original code.
; . N BSDXFLAGS S BSDXFLAGS=$P(BSDXNOD,U,2) ; No show and Cancel Flags
; . Q:BSDXFLAGS["C" ; if appt is cancelled, quit
;
Q
;
PADISPD(BSDXY,BSDXPAT) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("PADISP^BSDX27(.BSDXY,BSDXPAT)")
Q
;
PADISP(BSDXY,BSDXPAT) ;EP
;Return recordset of patient appointments used in listing
;a patient's appointments and generating patient letters.
;Called by rpc BSDX PATIENT APPT DISPLAY
;
; Sam's Notes:
; Relatively complex algorithm.
; 1. First, loop through ^DPT(DA,"S", and get all appointments.
; Exclude cancelled appts. Store in BSDXDPT array.
; 2. Go through ^BSDXAPPT("CPAT", (patient index) .
; Get the info from there and compar with BSDXDPT array. If
; they are the same, get all info, and rm entry from BSDXDPT array.
; 3. If there are any remaining entries in BSDXDPT (PIMS leftovers),
; Get the data from file 2 and 44.
;
N BSDXI,BSDXIEN,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCNID,BSDXCNOD,BSDXMADE,BSDXCLRK,BSDXNOT,BSDXQ
N BSDXSTRT
N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXY="^BSDXTMP("_$J_")"
S BSDXI=0
S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus"
S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30)
S X="ERROR^BSDX27",@^%ZOSF("TRAP")
;Get patient info
;
I '+BSDXPAT S ^BSDXTMP($J,1)=$C(31) Q
I '$D(^DPT(+BSDXPAT,0)) S ^BSDXTMP($J,1)=$C(31) Q
S BSDXNOD=$$PATINFO(BSDXPAT)
S BSDXNAM=$P(BSDXNOD,U) ;NAME
S BSDXSEX=$P(BSDXNOD,U,2) ;SEX
S BSDXDOB=$P(BSDXNOD,U,3) ;DOB
S BSDXHRN=$P(BSDXNOD,U,4) ;Health Record Number for location DUZ(2)
S BSDXSTRE=$P(BSDXNOD,U,5) ;Street
S BSDXCITY=$P(BSDXNOD,U,6) ;City
S BSDXST=$P(BSDXNOD,U,7) ;State
S BSDXZIP=$P(BSDXNOD,U,8) ;zip
S BSDXPHON=$P(BSDXNOD,U,9) ;homephone
;
;Organize ^DPT(BSDXPAT,"S," nodes
; into BSDXDPT(CLINIC,DATE)
;
I $D(^DPT(BSDXPAT,"S")) S BSDXDT=0 F S BSDXDT=$O(^DPT(BSDXPAT,"S",BSDXDT)) Q:'+BSDXDT D
. S BSDXNOD=$G(^DPT(BSDXPAT,"S",BSDXDT,0))
. S BSDXCID=$P(BSDXNOD,U)
. Q:'+BSDXCID
. Q:'$D(^SC(BSDXCID,0))
. N BSDXFLAGS S BSDXFLAGS=$P(BSDXNOD,U,2) ; No show and Cancel Flags
. Q:BSDXFLAGS["C" ; if appt is cancelled, quit
. S BSDXDPT(BSDXCID,BSDXDT)=BSDXNOD
;
;$O Through ^BSDX("CPAT",
S BSDXIEN=0
I $D(^BSDXAPPT("CPAT",BSDXPAT)) F S BSDXIEN=$O(^BSDXAPPT("CPAT",BSDXPAT,BSDXIEN)) Q:'BSDXIEN D
. N BSDXNOD,BSDXAPT,BSDXCID,BSDXCNOD,BSDXCLN,BSDX44,BSDXDNOD,BSDXSTAT,BSDX,BSDXTYPE,BSDXLIN
. S BSDXNOD=$G(^BSDXAPPT(BSDXIEN,0))
. Q:BSDXNOD=""
. Q:$P(BSDXNOD,U,12)]"" ;CANCELLED
. S Y=$P(BSDXNOD,U)
. Q:'+Y
. X ^DD("DD") S Y=$TR(Y,"@"," ")
. S BSDXAPT=Y ;Appointment date time
. S BSDXCLRK=$P(BSDXNOD,U,8) ;Appointment made by
. S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. S Y=$P(BSDXNOD,U,9) ;Date Appointment Made
. I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. S BSDXMADE=Y
. ;NOTE
. S BSDXNOT=""
. I $D(^BSDXAPPT(BSDXIEN,1,0)) S BSDXNOT="",BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXIEN,1,BSDXQ)) Q:'+BSDXQ D
. . S BSDXLIN=$G(^BSDXAPPT(BSDXIEN,1,BSDXQ,0))
. . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" "
. . S BSDXNOT=BSDXNOT_BSDXLIN
. ;Resource
. S BSDXCID=$P(BSDXNOD,U,7) ;IEN of BSDX RESOURCE
. Q:'+BSDXCID
. Q:'$D(^BSDXRES(BSDXCID,0))
. S BSDXCNOD=$G(^BSDXRES(BSDXCID,0)) ;BSDX RESOURCE node
. Q:BSDXCNOD=""
. S BSDXCLN=$P(BSDXCNOD,U) ;Text name of BSDX Resource
. S BSDX44=$P(BSDXCNOD,U,4) ;File 44 pointer
. ;If appt entry in ^DPT(PAT,"S" exists for this clinic, get the TYPE/STATUS info from
. ;the BSDXDPT array and delete the BSDXDPT node
. S BSDXTYPE=""
. I +BSDX44,$D(BSDXDPT(BSDX44,$P(BSDXNOD,U))) D ;BSDXNOD is the BSDX APPOINTMENT node
. . S BSDXDNOD=BSDXDPT(BSDX44,$P(BSDXNOD,U)) ;BSDXDNOD is a copy of the ^DPT(PAT,"S" node
. . S BSDXTYPE=$$STATUS(BSDXPAT,$P(BSDXNOD,U),BSDXDNOD) ;IHS/OIT/HMW 20050208 Added
. . K BSDXDPT(BSDX44,$P(BSDXNOD,U))
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
. Q
;
;Go through remaining BSDXDPT( entries
I $D(BSDXDPT) S BSDX44=0 D
. F S BSDX44=$O(BSDXDPT(BSDX44)) Q:'+BSDX44 S BSDXDT=0 D
. . F S BSDXDT=$O(BSDXDPT(BSDX44,BSDXDT)) Q:'+BSDXDT D
. . . S BSDXDNOD=BSDXDPT(BSDX44,BSDXDT)
. . . S Y=BSDXDT
. . . Q:'+Y
. . . X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXAPT=Y
. . . S BSDXTYPE=$$STATUS(BSDXPAT,BSDXDT,BSDXDNOD) ;IHS/OIT/HMW 20050208 Added
. . . S BSDXCLN=$P($G(^SC(BSDX44,0)),U)
. . . S BSDXCLRK=$P(BSDXDNOD,U,18)
. . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. . . S Y=$P(BSDXDNOD,U,19)
. . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXMADE=Y
. . . S BSDXNOT=""
. . . S BSDXI=BSDXI+1
. . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
. . . K BSDXDPT(BSDX44,BSDXDT)
;
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
STATUS(PAT,DATE,NODE) ; returns appt status
;IHS/OIT/HMW 20050208 Added from BSDDPA
NEW TYP
S TYP=$$APPTYP^BSDXAPI(PAT,DATE) ;sched vs. walkin
I $P(NODE,U,2)["C" Q TYP_" - CANCELLED"
I $P(NODE,U,2)'="NT",$P(NODE,U,2)["N" Q TYP_" - NO SHOW"
I $$CO^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED OUT"
I $$CI^BSDXAPI(PAT,+NODE,DATE) Q TYP_" - CHECKED IN"
Q TYP
;
ERROR ;
D ERR(BSDXI,"RPMS Error")
Q
;
ERR(BSDXI,ERRNO,MSG) ;Error processing
S:'$D(BSDXI) BSDXI=999
I +ERRNO S BSDXERR=ERRNO+134234112 ;vbObjectError
E S BSDXERR=ERRNO
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=MSG_"^^^^^^^^^^^^^^^"_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
PATINFO(BSDXPAT) ;EP
;Intrisic Function returns NAME^SEX^DOB^HRN^STREET^CITY^STATE^ZIP^PHONE for patient ien BSDXPAT
;DOB is in external format
;HRN depends on existence of DUZ(2)
;
N BSDXNOD,BSDXNAM,BSDXSEX,BSDXDOB,BSDXHRN,BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXNOD=^DPT(+BSDXPAT,0)
S BSDXNAM=$P(BSDXNOD,U) ;NAME
S BSDXSEX=$P(BSDXNOD,U,2)
S BSDXSEX=$S(BSDXSEX="F":"FEMALE",BSDXSEX="M":"MALE",1:"")
S Y=$P(BSDXNOD,U,3) I Y]"" X ^DD("DD") S Y=$TR(Y,"@"," ")
S BSDXDOB=Y ;DOB
S BSDXHRN=""
I $D(DUZ(2)) I DUZ(2)>0 S BSDXHRN=$P($G(^AUPNPAT(BSDXPAT,41,DUZ(2),0)),U,2) ;HRN
;
S BSDXNOD=$G(^DPT(+BSDXPAT,.11))
S (BSDXSTRT,BSDXCITY,BSDXST,BSDXZIP)=""
I BSDXNOD]"" D
. S BSDXSTRT=$E($P(BSDXNOD,U),1,50) ;STREET
. S BSDXCITY=$P(BSDXNOD,U,4) ;CITY
. S BSDXST=$P(BSDXNOD,U,5) ;STATE
. I +BSDXST,$D(^DIC(5,+BSDXST,0)) S BSDXST=$P(^DIC(5,+BSDXST,0),U,2)
. S BSDXZIP=$P(BSDXNOD,U,6) ;ZIP
;
S BSDXNOD=$G(^DPT(+BSDXPAT,.13)) ;PHONE
S BSDXPHON=$P(BSDXNOD,U)
;
Q BSDXNAM_U_BSDXSEX_U_BSDXDOB_U_BSDXHRN_U_BSDXSTRT_U_BSDXCITY_U_BSDXST_U_BSDXZIP_U_BSDXPHON
;
CLDISPD(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("CLDISP^BSDX27(.BSDXY,BSDXCLST,BSDXBEG,BSDXEND)")
Q
;
CLDISP(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP
;
;Return recordset of patient appointments
;between dates BSDXBEG and BSDXEND for each clinic in BSDXCLST.
;Used in listing a patient's appointments and generating patient letters.
;BSDXCLST is a |-delimited list of BSDX RESOURCE iens. (The last |-piece is null, so discard it.)
;BSDXBEG and BSDXEND are in external date form.
;Called by BSDX CLINIC LETTERS
;
; July 10, 2010 -- to support i18n, we pass dates from client in
; locale-neutral Fileman format. No need to convert it.
N BSDXI,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCID,BSDXCNOD,BSDXDT
N BSDXJ,BSDXAID,BSDXPAT,BSDXPNOD,BSDXCLN,BSDXCLRK,BSDXMADE,BSDXNOT,BSDXLIN
N BSDXSTRT
N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXY="^BSDXTMP("_$J_")"
K ^BSDXTMP($J)
S BSDXI=0
S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus"
S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30)
S X="ERROR^BSDX27",@^%ZOSF("TRAP")
;
;Convert beginning and ending dates
;
S BSDXBEG=BSDXBEG-1,BSDXBEG=BSDXBEG_".9999"
S BSDXEND=BSDXEND_".9999"
I BSDXCLST="" D ERR(BSDXI,0,"Routine: BSDX27, Error: Null clinic list") Q
;
;For each clinic in BSDXCLST $O through ^BSDXAPPT("ARSRC",ResourceIEN,FMDate,ApptIEN)
;
F BSDXJ=1:1:$L(BSDXCLST,"|")-1 S BSDXCID=$P(BSDXCLST,"|",BSDXJ) D
. S BSDXCLN=$G(^BSDXRES(BSDXCID,0)) S BSDXCLN=$P(BSDXCLN,U) Q:BSDXCLN=""
. S BSDXSTRT=BSDXBEG F S BSDXSTRT=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT)) Q:'+BSDXSTRT Q:BSDXSTRT>BSDXEND D
. . S BSDXAID=0 F S BSDXAID=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT,BSDXAID)) Q:'+BSDXAID D
. . . S BSDXNOD=$G(^BSDXAPPT(BSDXAID,0))
. . . Q:BSDXNOD=""
. . . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED
. . . Q:$P(BSDXNOD,U,13)="y" ;WALKIN
. . . S Y=$P(BSDXNOD,U)
. . . Q:'+Y
. . . X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXAPT=Y ;Appointment date time
. . . ;
. . . ;NOTE
. . . S BSDXNOT=""
. . . I $D(^BSDXAPPT(BSDXAID,1,0)) S BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXAID,1,BSDXQ)) Q:'+BSDXQ D
. . . . S BSDXLIN=$G(^BSDXAPPT(BSDXAID,1,BSDXQ,0))
. . . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" "
. . . . S BSDXNOT=BSDXNOT_BSDXLIN
. . . ;
. . . S BSDXPAT=$P(BSDXNOD,U,5)
. . . S BSDXPNOD=$$PATINFO(BSDXPAT)
. . . S BSDXNAM=$P(BSDXPNOD,U) ;NAME
. . . S BSDXSEX=$P(BSDXPNOD,U,2) ;SEX
. . . S BSDXDOB=$P(BSDXPNOD,U,3) ;DOB
. . . S BSDXHRN=$P(BSDXPNOD,U,4) ;Health Record Number for location DUZ(2)
. . . S BSDXSTRE=$P(BSDXPNOD,U,5) ;Street
. . . S BSDXCITY=$P(BSDXPNOD,U,6) ;City
. . . S BSDXST=$P(BSDXPNOD,U,7) ;State
. . . S BSDXZIP=$P(BSDXPNOD,U,8) ;zip
. . . S BSDXPHON=$P(BSDXPNOD,U,9) ;homephone
. . . S BSDXTYPE="" ;Type/status doesn't exist for BSDX APPT clinics and it's not needed for clinic letters
. . . S BSDXCLRK=$P(BSDXNOD,U,8)
. . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. . . S Y=$P(BSDXNOD,U,9)
. . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXMADE=Y
. . . S BSDXI=BSDXI+1
. . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
;
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;Entry point for debugging
;
;D DEBUG^%Serenji("CLDISP^BSDX27(.BSDXY,BSDXCLST,BSDXBEG,BSDXEND)")
Q
;
CLDISP(BSDXY,BSDXCLST,BSDXBEG,BSDXEND) ;EP
;
;Return recordset of patient appointments
;between dates BSDXBEG and BSDXEND for each clinic in BSDXCLST.
;Used in listing a patient's appointments and generating patient letters.
;BSDXCLST is a |-delimited list of BSDX RESOURCE iens. (The last |-piece is null, so discard it.)
;BSDXBEG and BSDXEND are in external date form.
;Called by BSDX CLINIC LETTERS
;
; July 10, 2010 -- to support i18n, we pass dates from client in
; locale-neutral Fileman format. No need to convert it.
N BSDXI,BSDXNOD,BSDXNAM,BSDXDOB,BSDXHRN,BSDXSEX,BSDXCID,BSDXCNOD,BSDXDT
N BSDXJ,BSDXAID,BSDXPAT,BSDXPNOD,BSDXCLN,BSDXCLRK,BSDXMADE,BSDXNOT,BSDXLIN
N BSDXSTRT
N BSDXSTRE,BSDXCITY,BSDXST,BSDXZIP,BSDXPHON
S BSDXY="^BSDXTMP("_$J_")"
K ^BSDXTMP($J)
S BSDXI=0
S ^BSDXTMP($J,BSDXI)="T00030Name^D00020DOB^T00030Sex^T00030HRN^D00030ApptDate^T00030Clinic^T00030TypeStatus"
S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^I00010RESOURCEID^T00030APPT_MADE_BY^D00020DATE_APPT_MADE^T00250NOTE^T00030STREET^T00030CITY^T00030STATE^T00030ZIP^T00030HOMEPHONE"_$C(30)
S X="ERROR^BSDX27",@^%ZOSF("TRAP")
;
;Convert beginning and ending dates
;
S BSDXBEG=BSDXBEG-1,BSDXBEG=BSDXBEG_".9999"
S BSDXEND=BSDXEND_".9999"
I BSDXCLST="" D ERR(BSDXI,0,"Routine: BSDX27, Error: Null clinic list") Q
;
;For each clinic in BSDXCLST $O through ^BSDXAPPT("ARSRC",ResourceIEN,FMDate,ApptIEN)
;
F BSDXJ=1:1:$L(BSDXCLST,"|")-1 S BSDXCID=$P(BSDXCLST,"|",BSDXJ) D
. S BSDXCLN=$G(^BSDXRES(BSDXCID,0)) S BSDXCLN=$P(BSDXCLN,U) Q:BSDXCLN=""
. S BSDXSTRT=BSDXBEG F S BSDXSTRT=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT)) Q:'+BSDXSTRT Q:BSDXSTRT>BSDXEND D
. . S BSDXAID=0 F S BSDXAID=$O(^BSDXAPPT("ARSRC",BSDXCID,BSDXSTRT,BSDXAID)) Q:'+BSDXAID D
. . . S BSDXNOD=$G(^BSDXAPPT(BSDXAID,0))
. . . Q:BSDXNOD=""
. . . Q:$P(BSDXNOD,U,12)]"" ;CANCELLED
. . . Q:$P(BSDXNOD,U,13)="y" ;WALKIN
. . . S Y=$P(BSDXNOD,U)
. . . Q:'+Y
. . . X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXAPT=Y ;Appointment date time
. . . ;
. . . ;NOTE
. . . S BSDXNOT=""
. . . I $D(^BSDXAPPT(BSDXAID,1,0)) S BSDXQ=0 F S BSDXQ=$O(^BSDXAPPT(BSDXAID,1,BSDXQ)) Q:'+BSDXQ D
. . . . S BSDXLIN=$G(^BSDXAPPT(BSDXAID,1,BSDXQ,0))
. . . . S:(BSDXLIN'="")&($E(BSDXLIN,$L(BSDXLIN)-1,$L(BSDXLIN))'=" ") BSDXLIN=BSDXLIN_" "
. . . . S BSDXNOT=BSDXNOT_BSDXLIN
. . . ;
. . . S BSDXPAT=$P(BSDXNOD,U,5)
. . . S BSDXPNOD=$$PATINFO(BSDXPAT)
. . . S BSDXNAM=$P(BSDXPNOD,U) ;NAME
. . . S BSDXSEX=$P(BSDXPNOD,U,2) ;SEX
. . . S BSDXDOB=$P(BSDXPNOD,U,3) ;DOB
. . . S BSDXHRN=$P(BSDXPNOD,U,4) ;Health Record Number for location DUZ(2)
. . . S BSDXSTRE=$P(BSDXPNOD,U,5) ;Street
. . . S BSDXCITY=$P(BSDXPNOD,U,6) ;City
. . . S BSDXST=$P(BSDXPNOD,U,7) ;State
. . . S BSDXZIP=$P(BSDXPNOD,U,8) ;zip
. . . S BSDXPHON=$P(BSDXPNOD,U,9) ;homephone
. . . S BSDXTYPE="" ;Type/status doesn't exist for BSDX APPT clinics and it's not needed for clinic letters
. . . S BSDXCLRK=$P(BSDXNOD,U,8)
. . . S:+BSDXCLRK BSDXCLRK=$G(^VA(200,BSDXCLRK,0)),BSDXCLRK=$P(BSDXCLRK,U)
. . . S Y=$P(BSDXNOD,U,9)
. . . I +Y X ^DD("DD") S Y=$TR(Y,"@"," ")
. . . S BSDXMADE=Y
. . . S BSDXI=BSDXI+1
. . . S ^BSDXTMP($J,BSDXI)=BSDXNAM_"^"_BSDXDOB_"^"_BSDXSEX_"^"_BSDXHRN_"^"_BSDXAPT_"^"_BSDXCLN_"^"_BSDXTYPE_"^"_BSDXCID_"^"_BSDXCLRK_"^"_BSDXMADE_"^"_BSDXNOT_"^"_BSDXSTRE_"^"_BSDXCITY_"^"_BSDXST_"^"_BSDXZIP_"^"_BSDXPHON_$C(30)
;
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q

2
m/BSDX28.m
View File

@ -1,5 +1,5 @@
BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:30pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; HMW 3050721 Added test for inactivated record

90
m/BSDX29.m
View File

@ -1,13 +1,13 @@
BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 6:05am
;;1.42;BSDX;;Sep 29, 2010
BSDX29 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:39pm
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; v1.3 by WV/SMH on 3100713
; - 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.42 by WV/SMH on 3101023
; - Transaction moved; now restartable too.
; --> Thanks to Zach Gonzalez and Rick Marshall.
; - Refactoring of major portions of routine
;
BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
;Entry point for debugging
@ -18,33 +18,33 @@ BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
BSDXCP(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND) ;EP
;Copy appointments from HOSPITAL LOCATION entry BSDX44 to BSDX RESOURCE entry BSDXRES
;Beginning with appointments on day BSDXBEG and ending on BSDXEND, inclusive
;Called by RPC: BSDX COPY APPOINTMENTS
;Called by RPC: BSDX COPY APPOINTMENTS
;
; Parameters:
; - BSDXY: Global Return
; - BSDXRES: BSDX RESOURCE to copy appointments to
; - BSDX44: Hospital Location IEN to copy appointments from
; - BSDXBEG: Beginning Date in FM Format
; - BSDXEND: End Date in FM Format
;
; Parameters:
; - BSDXY: Global Return
; - BSDXRES: BSDX RESOURCE to copy appointments to
; - BSDX44: Hospital Location IEN to copy appointments from
; - BSDXBEG: Beginning Date in FM Format
; - BSDXEND: End Date in FM Format
;
;Returns ADO Recordset containing TASK_NUMBER and ERRORID
;
; Return Array
; Return Array
S BSDXY=$NA(^BSDXTMP($J))
K ^BSDXTMP($J)
; $ET
N $ET S $ET="G ETRAP^BSDX29"
K ^BSDXTMP($J)
; $ET
N $ET S $ET="G ETRAP^BSDX29"
; Counter
N BSDXI S BSDXI=0
; Header Node
S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00020ERRORID"_$C(30)
N BSDXI S BSDXI=0
; Header Node
S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00100ERRORID"_$C(30)
;
; Make dates inclusive; add 1 to FM dates
S BSDXBEG=BSDXBEG-1
; Make dates inclusive; add 1 to FM dates
S BSDXBEG=BSDXBEG-1
S BSDXEND=BSDXEND+1
;
; Taskman variables
N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
; Taskman variables
N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
; Task Load
S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS"
S ZTSAVE("BSDXBEG")="",ZTSAVE("BSDXEND")="",ZTSAVE("BSDX44")="",ZTSAVE("BSDXRES")=""
@ -60,30 +60,30 @@ ZTMD ;EP - Debug entry point
Q
;
ZTM ;EP - Taskman entry point
; Variables set up in ZTSAVE above
;
; Variables set up in ZTSAVE above
;
Q:'$D(ZTSK)
; $ET
N $ET S $ET="G ZTMERR^BSDX29"
; $ET
N $ET S $ET="G ZTMERR^BSDX29"
; Txn
TSTART (BSDXBEG,BSDXEND,BSDX44,BSDXRES):T="BSDX COPY APPOINTMENT^BSDX29"
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
N BSDXQUIT S BSDXQUIT=0 ; Quit Flag to be retrieved from an external proc
; Set Count
S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
; Loop through dates here.
F S BSDXBEG=$O(^SC(BSDX44,"S",BSDXBEG)) Q:'+BSDXBEG Q:BSDXBEG>BSDXEND Q:BSDXQUIT D
. ; Loop through Entries in each date in the subsubfile.
. ; Quit if we are at the end or if a remote process requests a quit.
. N BSDXIEN S BSDXIEN=0
F S BSDXBEG=$O(^SC(BSDX44,"S",BSDXBEG)) Q:'+BSDXBEG Q:BSDXBEG>BSDXEND Q:BSDXQUIT D
. ; Loop through Entries in each date in the subsubfile.
. ; Quit if we are at the end or if a remote process requests a quit.
. N BSDXIEN S BSDXIEN=0
. F S BSDXIEN=$O(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN)) Q:'+BSDXIEN Q:BSDXQUIT D
. . 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
. . N BSDXPAT S BSDXPAT=$P(BSDXNOD,U) ; Patient
. . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) ;duration in minutes
. . 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)
. . N BSDXMADE S BSDXMADE=$P(BSDXNOD,U,7) ;date appt made
. . N BSDXNOTE S BSDXNOTE=$P(BSDXNOD,U,4) ;'OTHER' field contains note
@ -99,10 +99,10 @@ ZTM ;EP - Taskman entry point
;
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
; Rollback before logging the error
I $TL>0 TROLLBACK
D ^%ZTER
S $EC="" ; Clear Error
S $EC="" ; Clear Error
QUIT
;
XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
@ -147,7 +147,7 @@ XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE) ;EP
;
ERR(BSDXI,BSDXCNT,BSDXERR) ;Error processing
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
S BSDXERR=$TR(BSDXERR,"^","~")
S ^BSDXTMP($J,BSDXI)=BSDXCNT_"^"_BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
@ -155,9 +155,9 @@ ERR(BSDXI,BSDXCNT,BSDXERR) ;Error processing
;
ETRAP ;EP Error trap entry
; No Txn here. So don't rollback anything
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
D ^%ZTER
S $EC="" ; Clear error
N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
D ^%ZTER
S $EC="" ; Clear error
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(BSDXI,$G(BSDXCNT),"~100~BSDX29, Error: "_$G(%ZTERZE))
Q

2
m/BSDX2E.m
View File

@ -1,5 +1,5 @@
BSDX2E ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [7/18/10 4:30pm]
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
S LINE="",$P(LINE,"*",81)=""
S XPDNOQUE="NO QUE" ;NO QUEUING ALLOWED

2
m/BSDX30.m
View File

@ -1,5 +1,5 @@
BSDX30 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [ 09/12/2007 1:54 PM ]
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
SPACED(BSDXY,BSDXDIC,BSDXVAL) ;EP

413
m/BSDX31.m
View File

@ -1,194 +1,219 @@
BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 8:25am
;;1.42;BSDX;;Sep 29, 2010
; Change Log:
; 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
; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT)
; -3: No-show flag is invalid
; -100: M Error
;
;
NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP
;Entry point for debugging
;
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
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
;
; Parameters:
; BSDXY: Global Return
; BSDXAPTID is entry number in BSDX APPOINTMENT file
; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO
;
; Returns ADO.net record set with fields
; - ERRORID; ERRORTEXT
; ERRORID of 1 is okay
; Anything else is an error.
;
; 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)="I00020ERRORID^T00030ERRORTEXT"_$C(30)
; Begin transaction
TSTART (BSDXI,BSDXY,BSDXAPTID,BSDXNS):T="BSDX NOSHOW CANCEL^BSDX29"
; 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
; 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
; 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
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)
;
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
;
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)=BSDXNS ;NOSHOW
D FILE^DIE("","BSDXFDA","BSDXMSG")
QUIT
;
NOSEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX NOSHOW APPOINTMENT event
;when appointments NOSHOW via PIMS interface.
;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients
;
Q:+$G(BSDXNOEV)
Q:'+$G(BSDXSC)
Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK"
N BSDXSTAT,BSDXFOUND,BSDXRES
S BSDXSTAT=1
S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0
S BSDXFOUND=0
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D NOSEVT3(BSDXRES) Q
I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D NOSEVT3(BSDXRES)
Q
;
NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
;Get appointment id in BSDXAPT
;If found, call BSDXNOS(BSDXAPPT) and return 1
;else return 0
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) D BSDXNOS(BSDXAPPT,BSDXSTAT)
Q BSDXFOUND
;
NOSEVT3(BSDXRES) ;
;Call RaiseEvent to notify GUI clients
;
N BSDXRESN
S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
Q:BSDXRESN=""
S BSDXRESN=$P(BSDXRESN,"^")
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
;
ERR(BSDXERID,ERRTXT) ;Error processing
S BSDXI=BSDXI+1
TROLLBACK
S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(BSDXI) N BSDXI S BSDXI=999999
S BSDXI=BSDXI+1
D ERR(0,"BSDX31 Error: "_$G(%ZTERROR))
Q
;
IMHERE(BSDXRES) ;EP
;Entry point for BSDX IM HERE remote procedure
S BSDXRES=1
Q
;
BSDX31 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 12/6/10 12:39pm
;;1.42;BSDX;;Dec 07, 2010
; Change Log:
; 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
; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT)
; -3: No-show flag is invalid
; -4: Filing of No-show in ^BSDXAPPT failed
; -5: Filing of No-show in ^DPT failed (BSDXAPI error)
; -100: M Error
;
;
NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP
;Entry point for debugging
;
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
;
; Parameters:
; BSDXY: Global Return
; BSDXAPTID is entry number in BSDX APPOINTMENT file
; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO
;
; Returns ADO.net record set with fields
; - ERRORID; ERRORTEXT
; ERRORID of 1 is okay
; Anything else is an error.
;
; 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)
; 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
; 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
; 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
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)
;
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
;
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)=BSDXNS ;NOSHOW
D FILE^DIE("","BSDXFDA","BSDXMSG")
QUIT
;
NOSEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX NOSHOW APPOINTMENT event
;when appointments NOSHOW via PIMS interface.
;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients
;
Q:+$G(BSDXNOEV)
Q:'+$G(BSDXSC)
Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK"
N BSDXSTAT,BSDXFOUND,BSDXRES
S BSDXSTAT=1
S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0
S BSDXFOUND=0
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D NOSEVT3(BSDXRES) Q
I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
I BSDXFOUND D NOSEVT3(BSDXRES)
Q
;
NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT) ;
;Get appointment id in BSDXAPT
;If found, call BSDXNOS(BSDXAPPT) and return 1
;else return 0
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) D BSDXNOS(BSDXAPPT,BSDXSTAT)
Q BSDXFOUND
;
NOSEVT3(BSDXRES) ;
;Call RaiseEvent to notify GUI clients
;
N BSDXRESN
S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
Q:BSDXRESN=""
S BSDXRESN=$P(BSDXRESN,"^")
D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
Q
;
;
ERR(BSDXERID,ERRTXT) ;Error processing
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)
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
S $EC="" ; Clear Error
; Send to client
I '$D(BSDXI) N BSDXI S BSDXI=0
D ERR(-100,"BSDX31 Error: "_$G(%ZTERZE))
QUIT
;
IMHERE(BSDXRES) ;EP
;Entry point for BSDX IM HERE remote procedure
S BSDXRES=1
Q
;

2
m/BSDX32.m
View File

@ -1,5 +1,5 @@
BSDX32 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 9/29/10 10:21am
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
ERROR ;

2
m/BSDX33.m
View File

@ -1,5 +1,5 @@
BSDX33 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:33pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
; Mods by WV/STAR
;
; Change Log:

2
m/BSDX34.m
View File

@ -1,5 +1,5 @@
BSDX34 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/15/10 12:37pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
; Change Log:
; July 10 2010:

2
m/BSDX35.m
View File

@ -1,5 +1,5 @@
BSDX35 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
Q

55
m/BSDXAPI.m
View File

@ -1,17 +1,22 @@
BSDXAPI ; IHS/ANMC/LJF - SCHEDULING APIs ; 12/6/10 6:01am
;;1.42;BSDX;;Sep 29, 2010;Build 7
BSDXAPI ; IHS/ANMC/LJF - SCHEDULING APIs ; 12/6/10 5:50pm
;;1.42;BSDX;;Dec 07, 2010;Build 7
;Orignal routine is BSDAPI by IHS/LJF, HMW, and MAW
;local mods (many) by WV/SMH
;Move to BSDX namespace as BSDXAPI from BSDAPI by WV/SMH
; Change History:
; 2010-11-5:
; - 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:
; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well.
; 2010-12-5
; Added an entry point to update the patient note in file 44.
; 2010-12-6
; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI")
; 2010-11-12:
; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well.
; 2010-12-5
; Added an entry point to update the patient note in file 44.
; 2010-12-6
; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI")
; 2010-12-8
; 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.
;
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
@ -50,7 +55,7 @@ MAKE(BSDR) ;PEP; call to store appt made
I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12) ;remove seconds
I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
;
I ($G(BSDR("LEN"))<5)!($G(BSDR("LEN"))>240) Q 1_U_"Appt Length error: "_$G(BSDR("LEN"))
;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")
;
@ -279,19 +284,19 @@ CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
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
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/BSDXGPRV.m
View File

@ -1,5 +1,5 @@
BSDXGPRV ; WV/SMH - WINDOWS SCHEDULING RPCS ; 11/2/10 4:27pm
;;1.41;BSDX;;Sep 29, 2010
;;1.42;BSDX;;Dec 07, 2010
;
;
ERROR ;