BSDX08 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
;
APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
;Entry point for debugging
;
;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
Q
;
APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
;Called by BSDX CANCEL APPOINTMENT
;Cancels appointment
;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
;
N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXERR
N BSDXLOC,BSDXLEN,BSDXSCIEN
N BSDXNOEV
S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
;
D ^XBKVAR S X="ETRAP^BSDX08",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)
S BSDXI=BSDXI+1
TSTART
I '+BSDXAPTID D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"BSDX08: Invalid Appointment ID") Q
;
;Delete APPOINTMENT entries
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
S BSDXPATID=$P(BSDXNOD,U,5)
S BSDXSTART=$P(BSDXNOD,U)
;
;Lock BSDX node
L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later") TROLLBACK Q
;cancel BSDX APPOINTMENT record
D BSDXCAN(BSDXAPTID)
;
S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I +$G(BSDXZ) S BSDXERR=BSDXERR_$P(BSDXZ,U,2) D ERR(BSDXI,BSDXERR) Q
. S BSDXNOD=^BSDXRES(BSDXSC1,0)
. S BSDXLOC=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
. Q:'+BSDXLOC
. S BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART) I BSDXSCIEN="" D I 'BSDXZ Q ;Q:BSDXZ
. . S BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
. . S BSDXZ=1
. . I '$D(^BSDXRES(BSDXSC1,20)) S BSDXZ=0 Q
. . 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))
. . . S BSDXLOC=$P(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
. . . S BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART) I +BSDXSCIEN S BSDXZ=0 Q
. S BSDXERR="BSDX08: CANCEL^BSDAPI Returned "
. I BSDXLOC']"" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
. I '$D(^SC(BSDXLOC,0)) S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
. S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
. I BSDXNOD="" S BSDXZ="0^Unable to find associated RPMS appointment for this patient." Q
. S BSDXLEN=$P(BSDXNOD,U,2)
. D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXAPTID,BSDXLEN)
. Q:+$G(BSDXZ)
. D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
. ;L
;
TCOMMIT
L -^BSDXAPPT(BSDXPATID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=""_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
;See SDCNP0
S (SD,S)=BSDXSTART
S I=BSDXSCD
Q:'$D(^SC(I,"ST",SD\1,1))
S SL=^SC(I,"SL"),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(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
S SL=BSDXLEN
S S=^SC(I,"ST",SD\1,1),Y=SD#1-SB*100,ST=Y#1*SI\.6+(Y\1*SI),SS=SL*HSI/60
I Y'<1 F I=ST+ST:SDDIF S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y="" S S=$E(S,1,I)_Y_$E(S,I+2,999),SS=SS-1 Q:SS'>0
S ^SC(BSDXSCD,"ST",SD\1,1)=S
Q
;
APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD,BSDXAPTID,BSDXLEN) ;
;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
;at time BSDXSD
N BSDXPNOD,BSDXC,DA,DIE,DPTST,DR,%H
;save data in case of uncancel (status & appt length)
S BSDXPNOD=^DPT(BSDXPATID,"S",BSDXSD,0)
S DPTST=$P(BSDXPNOD,U,2)
S DIE=9002018.4
S DA=BSDXAPTID
S DR=".17///"_DPTST_";"_".18///"_BSDXLEN
D ^DIE
S BSDXC("PAT")=BSDXDFN
S BSDXC("CLN")=BSDXLOC
S BSDXC("TYP")=BSDXTYP
S BSDXC("ADT")=BSDXSD
S %H=$H D YMD^%DTC
S BSDXC("CDT")=X+%
S BSDXC("NOT")=BSDXNOT
S:'+$G(BSDXCR) BSDXCR=14 ;UNKNOWN REASON
S BSDXC("CR")=BSDXCR
S BSDXC("USR")=DUZ
;
S BSDXZ=$$CANCEL(.BSDXC)
Q
;
BSDXCAN(BSDXAPTID) ;
;Cancel BSDX APPOINTMENT entry
N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")
S BSDXDATE=Y
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
K BSDXMSG
D FILE^DIE("","BSDXFDA","BSDXMSG")
Q
;
CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
;when appointments cancelled via PIMS interface.
;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
N BSDXFOUND,BSDXRES
Q:+$G(BSDXNOEV)
Q:'+$G(BSDXSC)
S BSDXFOUND=0
I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
I BSDXFOUND D CANEVT3(BSDXRES) Q
I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
I BSDXFOUND D CANEVT3(BSDXRES)
Q
;
CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
;Get appointment id in BSDXAPT
;If found, call BSDXCAN(BSDXAPPT) and return 1
;else return 0
N BSDXFOUND,BSDXAPPT
S BSDXFOUND=0
Q:'+BSDXRES BSDXFOUND
Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
S BSDXAPPT=0 F S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT D Q:BSDXFOUND
. 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 BSDXCAN(BSDXAPPT)
Q BSDXFOUND
;
CANEVT3(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
;
CANCEL(BSDR) ;EP; called to cancel appt
;
; Make call using: S ERR=$$CANCEL^BSDAPI(.ARRAY)
;
; Input Array -
; BSDR("PAT") = ien of patient in file 2
; BSDR("CLN") = ien of clinic in file 44
; BSDR("TYP") = C for canceled by clinic; PC for patient canceled
; BSDR("ADT") = appointment date and time
; BSDR("CDT") = cancel date and time
; BSDR("USR") = user who canceled appt
; BSDR("CR") = cancel reason - pointer to file 409.2
; BSDR("NOT") = cancel remarks - optional notes to 160 characters
;
;Output: error status and message
; = 0 or null: everything okay
; = 1^message: error and reason
;
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I ($G(BSDR("TYP"))'="C"),($G(BSDR("TYP"))'="PC") Q 1_U_"Cancel Status error: "_$G(BSDR("TYP"))
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("CDT")) S BSDR("CDT")=+$E(BSDR("CDT"),1,12) ;remove seconds
I $G(BSDR("CDT"))'?7N1".".4N Q 1_U_"Cancel Date/Time error: "_$G(BSDR("CDT"))
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))
I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))
;
NEW IEN,DIE,DA,DR
S IEN=$$SCIEN^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
;
I $$CI^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
;
; remember before status
NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
;
; get user who made appt and date appt made from ^SC
; because data in ^SC will be deleted
NEW USER,DATE
S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
;
; update file 2 info
NEW DIE,DA,DR
S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT
S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)
D ^DIE
;
; delete data in ^SC
NEW DIK,DA
S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
D ^DIK
Q 0
;
APPUDEL(BSDXY,BSDXAPTID) ;EP Undo Cancel
;called by BSDX UNCANCEL APPT
; BSDXAPTID = ien of appointment in BSDX APPOINTMENT (^BSDXAPPT) file 9002018.4
N BSDXDAM,BSDXDEC,BSDXI,BSDXNOD,BSDXPATID,BSDXSTART
S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
;
D ^XBKVAR S X="ETRAP^BSDX08",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30)
TSTART
I '+BSDXAPTID TROLLBACK D ERR(BSDXI+1,"Invalid Appointment ID.") Q
I '$D(^BSDXAPPT(BSDXAPTID,0)) TROLLBACK D ERR(BSDXI+1,"Invalid Appointment ID") Q
;Make sure appointment is cancelled
I $$GET1^DIQ(9002018.4,BSDXAPTID_",",.12)="" TROLLBACK D ERR(BSDXI+1,"Appointment is not Cancelled.") Q
;appts cancelled by patient cannot be uncancelled.
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
I $P(^DPT($P(BSDXNOD,U,5),"S",$P(BSDXNOD,U,1),0),U,2)="PC" TROLLBACK D ERR(BSDXI+1,"Cancelled by patient appointment can not be uncancelled.") Q
;get appointment data
S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
S BSDXDAM=$P(BSDXNOD,U,9) ;date appt made
S BSDXDEC=$P(BSDXNOD,U,8) ;data entry clerk
S BSDXLEN=$P(BSDXNOD,U,18) ;length of appt in minutes
S BSDXNOTE=$G(^BSDXAPPT(BSDXAPTID,1,1,0)) ;note from BSDX APPOINTMENT
S BSDXPATID=$P(BSDXNOD,U,5) ;pointer to VA PATIENT file 2
S BSDXSC1=$P($G(BSDXNOD),U,7) ;resource
S BSDXSTART=$P(BSDXNOD,U) ;appt start time
S BSDXWKIN=$P($G(BSDXNOD),U,13) ;walkin
;lock BSDX node
L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later") TROLLBACK Q
;uncancel BSDX APPOINTMENT
D BSDXUCAN(BSDXAPTID)
I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D I +$G(BSDXZ) S BSDXERR=BSDXERR_$P(BSDXZ,U,2) D ERR(BSDXI,BSDXERR) Q
. S BSDXNOD=^BSDXRES(BSDXSC1,0)
. S BSDXLOC=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
. Q:'+BSDXLOC
. ;uncancel patient appointment and re-instate clinic appointment
. S BSDXZ=""
. D APUCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXSC1,BSDXWKIN)
TCOMMIT
L -^BSDXAPPT(BSDXPATID)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=""_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
BSDXUCAN(BSDXAPTID) ;called internally to update BSDX APPOINTMENT by clearing cancel date/time
S BSDXIENS=BSDXAPTID_","
S BSDXFDA(9002018.4,BSDXIENS,.12)=""
K BSDXMSG
D FILE^DIE("","BSDXFDA","BSDXMSG")
Q
;
APUCAN(BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXRES,BSDXWKIN) ;
;unCancel appointment for patient BSDXDFN in clinic BSDXSC1
; BSDXLOC = pointer to hospital location ^SC file 44
; BSDXPATID = pointer to VA Patient ^DPT file 2
; BSDXSTART = Appointment time
; BSDXDAM = Date appointment made in FM format
; BSDXDEC = Data entry clerk - pointer to NEW PERSON file 200
N BSDXC,%H
S BSDXC("PAT")=BSDXPATID
S BSDXC("CLN")=BSDXLOC
S BSDXC("ADT")=BSDXSTART
S BSDXC("NOTE")=BSDXNOTE ;user note
S BSDXC("RES")=BSDXRES
S BSDXC("USR")=DUZ
S BSDXC("LEN")=BSDXLEN
S BSDXC("WKIN")=BSDXWKIN
;
S BSDXZ=$$UNCANCEL(.BSDXC)
Q
;
UNCANCEL(BSDR) ;PEP; called to ucancel appt
;
; Make call using: S ERR=$$UNCANCEL(.ARRAY)
;
; Input Array -
; BSDR("PAT") = ien of patient in file 2
; BSDR("CLN") = ien of clinic in file 44
; BSDR("ADT") = appointment date and time
; BSDR("USR") = user who uncanceled appt
; BSDR("NOTE") = appointment note from BSDX APPOINTMENT
; BSDR("LEN") = appt length in minutes (numeric)
; BSDR("RES") = resource
; BSDR("WKIN")= walkin
;
;Output: error status and message
; = 0 or null: everything okay
; = 1^message: error and reason
;
N DPTNOD,DPTNODR
I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
I $G(BSDR("ADT")) S BSDR("ADT")=+$E(BSDR("ADT"),1,12) ;remove seconds
I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))
;
S BSDXERR=$$APPRPMS^BSDX07(BSDR("LEN"),BSDR("NOTE"),BSDR("PAT"),BSDR("RES"),BSDR("ADT"),BSDR("WKIN"))
Q BSDXERR
;
ERR(BSDXI,BSDXERR) ;Error processing
S BSDXI=BSDXI+1
S BSDXERR=$TR(BSDXERR,"^","~")
TROLLBACK
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
L
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(BSDXI) N BSDXI S BSDXI=999999
S BSDXI=BSDXI+1
D ERR(BSDXI,"BSDX08 Error: "_$G(%ZTERROR))
Q
BSDX08 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ;
APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
+1 ;Entry point for debugging
+2 ;
+3 ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
+4 QUIT
+5 ;
APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
+1 ;Called by BSDX CANCEL APPOINTMENT
+2 ;Cancels appointment
+3 ;BSDXAPTID is entry number in BSDX APPOINTMENT file
+4 ;BSDXTYP is C for clinic-cancelled and PC for patient cancelled
+5 ;BSDXCR is pointer to CANCELLATION REASON File (409.2)
+6 ;BSDXNOT is user note
+7 ;Returns error code in recordset field ERRORID
+8 ;
+9 NEW BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXERR
+10 NEW BSDXLOC,BSDXLEN,BSDXSCIEN
+11 NEW BSDXNOEV
+12 ;Don't execute BSDX CANCEL APPOINTMENT protocol
SET BSDXNOEV=1
+13 ;
+14 DO ^XBKVAR
SET X="ETRAP^BSDX08"
SET @^%ZOSF("TRAP")
+15 SET BSDXI=0
+16 KILL ^BSDXTMP($JOB)
+17 SET BSDXY="^BSDXTMP("_$JOB_")"
+18 SET ^BSDXTMP($JOB,BSDXI)="T00020ERRORID"_$CHAR(30)
+19 SET BSDXI=BSDXI+1
+20 TSTART
+21 IF '+BSDXAPTID
DO ERR(BSDXI,"BSDX08: Invalid Appointment ID")
QUIT
+22 IF '$DATA(^BSDXAPPT(BSDXAPTID,0))
DO ERR(BSDXI,"BSDX08: Invalid Appointment ID")
QUIT
+23 ;
+24 ;Delete APPOINTMENT entries
+25 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+26 SET BSDXPATID=$PIECE(BSDXNOD,U,5)
+27 SET BSDXSTART=$PIECE(BSDXNOD,U)
+28 ;
+29 ;Lock BSDX node
+30 LOCK +^BSDXAPPT(BSDXPATID):5
IF '$TEST
DO ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later")
TROLLBACK
QUIT
+31 ;cancel BSDX APPOINTMENT record
+32 DO BSDXCAN(BSDXAPTID)
+33 ;
+34 ;RESOURCEID
SET BSDXSC1=$PIECE(BSDXNOD,U,7)
+35 IF BSDXSC1]""
IF $DATA(^BSDXRES(BSDXSC1,0))
Begin DoDot:1
+36 SET BSDXNOD=^BSDXRES(BSDXSC1,0)
+37 ;HOSPITAL LOCATION
SET BSDXLOC=$PIECE(BSDXNOD,U,4)
+38 IF '+BSDXLOC
QUIT
+39 ;Q:BSDXZ
SET BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART)
IF BSDXSCIEN=""
Begin DoDot:2
+40 SET BSDXERR="BSDX08: Unable to find associated RPMS appointment for this patient. "
+41 SET BSDXZ=1
+42 IF '$DATA(^BSDXRES(BSDXSC1,20))
SET BSDXZ=0
QUIT
+43 NEW BSDX1
+44 SET BSDX1=0
+45 FOR
SET BSDX1=$ORDER(^BSDXRES(BSDXSC1,20,BSDX1))
IF '+BSDX1
QUIT
IF BSDXZ=0
QUIT
Begin DoDot:3
+46 IF '$DATA(^BSDXRES(BSDXSC1,20,BSDX1,0))
QUIT
+47 SET BSDXLOC=$PIECE(^BSDXRES(BSDXSC1,20,BSDX1,0),U)
+48 SET BSDXSCIEN=$$SCIEN^BSDU2(BSDXPATID,BSDXLOC,BSDXSTART)
IF +BSDXSCIEN
SET BSDXZ=0
QUIT
End DoDot:3
End DoDot:2
IF 'BSDXZ
QUIT
+49 SET BSDXERR="BSDX08: CANCEL^BSDAPI Returned "
+50 IF BSDXLOC']""
SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."
QUIT
+51 IF '$DATA(^SC(BSDXLOC,0))
SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."
QUIT
+52 SET BSDXNOD=$GET(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
+53 IF BSDXNOD=""
SET BSDXZ="0^Unable to find associated RPMS appointment for this patient."
QUIT
+54 SET BSDXLEN=$PIECE(BSDXNOD,U,2)
+55 DO APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXAPTID,BSDXLEN)
+56 IF +$GET(BSDXZ)
QUIT
+57 DO AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
+58 ;L
End DoDot:1
IF +$GET(BSDXZ)
SET BSDXERR=BSDXERR_$PIECE(BSDXZ,U,2)
DO ERR(BSDXI,BSDXERR)
QUIT
+59 ;
+60 TCOMMIT
+61 LOCK -^BSDXAPPT(BSDXPATID)
+62 SET BSDXI=BSDXI+1
+63 SET ^BSDXTMP($JOB,BSDXI)=""_$CHAR(30)
+64 SET BSDXI=BSDXI+1
+65 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+66 QUIT
+67 ;
AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ;Update RPMS Clinic availability
+1 ;See SDCNP0
+2 SET (SD,S)=BSDXSTART
+3 SET I=BSDXSCD
+4 IF '$DATA(^SC(I,"ST",SD\1,1))
QUIT
+5 SET SL=^SC(I,"SL")
SET X=$PIECE(SL,U,3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X:X,1:4)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
KILL Y
+6 SET SL=BSDXLEN
+7 SET S=^SC(I,"ST",SD\1,1)
SET Y=SD#1-SB*100
SET ST=Y#1*SI\.6+(Y\1*SI)
SET SS=SL*HSI/60
+8 IF Y'<1
FOR I=ST+ST:SDDIF
SET Y=$EXTRACT(STR,$FIND(STR,$EXTRACT(S,I+1)))
IF Y=""
QUIT
SET S=$EXTRACT(S,1,I)_Y_$EXTRACT(S,I+2,999)
SET SS=SS-1
IF SS'>0
QUIT
+9 SET ^SC(BSDXSCD,"ST",SD\1,1)=S
+10 QUIT
+11 ;
APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD,BSDXAPTID,BSDXLEN) ;
+1 ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
+2 ;at time BSDXSD
+3 NEW BSDXPNOD,BSDXC,DA,DIE,DPTST,DR,%H
+4 ;save data in case of uncancel (status & appt length)
+5 SET BSDXPNOD=^DPT(BSDXPATID,"S",BSDXSD,0)
+6 SET DPTST=$PIECE(BSDXPNOD,U,2)
+7 SET DIE=9002018.4
+8 SET DA=BSDXAPTID
+9 SET DR=".17///"_DPTST_";"_".18///"_BSDXLEN
+10 DO ^DIE
+11 SET BSDXC("PAT")=BSDXDFN
+12 SET BSDXC("CLN")=BSDXLOC
+13 SET BSDXC("TYP")=BSDXTYP
+14 SET BSDXC("ADT")=BSDXSD
+15 SET %H=$HOROLOG
DO YMD^%DTC
+16 SET BSDXC("CDT")=X+%
+17 SET BSDXC("NOT")=BSDXNOT
+18 ;UNKNOWN REASON
IF '+$GET(BSDXCR)
SET BSDXCR=14
+19 SET BSDXC("CR")=BSDXCR
+20 SET BSDXC("USR")=DUZ
+21 ;
+22 SET BSDXZ=$$CANCEL(.BSDXC)
+23 QUIT
+24 ;
BSDXCAN(BSDXAPTID) ;
+1 ;Cancel BSDX APPOINTMENT entry
+2 NEW %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
+3 ; X ^DD("DD")
SET %DT="XT"
SET X="NOW"
DO ^%DT
+4 SET BSDXDATE=Y
+5 SET BSDXIENS=BSDXAPTID_","
+6 SET BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
+7 KILL BSDXMSG
+8 DO FILE^DIE("","BSDXFDA","BSDXMSG")
+9 QUIT
+10 ;
CANEVT(BSDXPAT,BSDXSTART,BSDXSC) ;EP Called by BSDX CANCEL APPOINTMENT event
+1 ;when appointments cancelled via PIMS interface.
+2 ;Propagates cancellation to BSDXAPPT and raises refresh event to running GUI clients
+3 NEW BSDXFOUND,BSDXRES
+4 IF +$GET(BSDXNOEV)
QUIT
+5 IF '+$GET(BSDXSC)
QUIT
+6 SET BSDXFOUND=0
+7 IF $DATA(^BSDXRES("ALOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ALOC",BSDXSC,0))
SET BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
+8 IF BSDXFOUND
DO CANEVT3(BSDXRES)
QUIT
+9 IF $DATA(^BXDXRES("ASSOC",BSDXSC))
SET BSDXRES=$ORDER(^BSDXRES("ASSOC",BSDXSC,0))
SET BSDXFOUND=$$CANEVT1(BSDXRES,BSDXSTART,BSDXPAT)
+10 IF BSDXFOUND
DO CANEVT3(BSDXRES)
+11 QUIT
+12 ;
CANEVT1(BSDXRES,BSDXSTART,BSDXPAT) ;
+1 ;Get appointment id in BSDXAPT
+2 ;If found, call BSDXCAN(BSDXAPPT) and return 1
+3 ;else return 0
+4 NEW BSDXFOUND,BSDXAPPT
+5 SET BSDXFOUND=0
+6 IF '+BSDXRES
QUIT BSDXFOUND
+7 IF '$DATA(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART))
QUIT BSDXFOUND
+8 SET BSDXAPPT=0
FOR
SET BSDXAPPT=$ORDER(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT))
IF '+BSDXAPPT
QUIT
Begin DoDot:1
+9 SET BSDXNOD=$GET(^BSDXAPPT(BSDXAPPT,0))
IF BSDXNOD=""
QUIT
+10 IF $PIECE(BSDXNOD,U,5)=BSDXPAT
IF $PIECE(BSDXNOD,U,12)=""
SET BSDXFOUND=1
QUIT
End DoDot:1
IF BSDXFOUND
QUIT
+11 IF BSDXFOUND
IF +$GET(BSDXAPPT)
DO BSDXCAN(BSDXAPPT)
+12 QUIT BSDXFOUND
+13 ;
CANEVT3(BSDXRES) ;
+1 ;Call RaiseEvent to notify GUI clients
+2 ;
+3 NEW BSDXRESN
+4 SET BSDXRESN=$GET(^BSDXRES(BSDXRES,0))
+5 IF BSDXRESN=""
QUIT
+6 SET BSDXRESN=$PIECE(BSDXRESN,"^")
+7 ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
+8 DO EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
+9 QUIT
+10 ;
CANCEL(BSDR) ;EP; called to cancel appt
+1 ;
+2 ; Make call using: S ERR=$$CANCEL^BSDAPI(.ARRAY)
+3 ;
+4 ; Input Array -
+5 ; BSDR("PAT") = ien of patient in file 2
+6 ; BSDR("CLN") = ien of clinic in file 44
+7 ; BSDR("TYP") = C for canceled by clinic; PC for patient canceled
+8 ; BSDR("ADT") = appointment date and time
+9 ; BSDR("CDT") = cancel date and time
+10 ; BSDR("USR") = user who canceled appt
+11 ; BSDR("CR") = cancel reason - pointer to file 409.2
+12 ; BSDR("NOT") = cancel remarks - optional notes to 160 characters
+13 ;
+14 ;Output: error status and message
+15 ; = 0 or null: everything okay
+16 ; = 1^message: error and reason
+17 ;
+18 IF '$DATA(^DPT(+$GET(BSDR("PAT")),0))
QUIT 1_U_"Patient not on file: "_$GET(BSDR("PAT"))
+19 IF '$DATA(^SC(+$GET(BSDR("CLN")),0))
QUIT 1_U_"Clinic not on file: "_$GET(BSDR("CLN"))
+20 IF ($GET(BSDR("TYP"))'="C")
IF ($GET(BSDR("TYP"))'="PC")
QUIT 1_U_"Cancel Status error: "_$GET(BSDR("TYP"))
+21 ;remove seconds
IF $GET(BSDR("ADT"))
SET BSDR("ADT")=+$EXTRACT(BSDR("ADT"),1,12)
+22 IF $GET(BSDR("ADT"))'?7N1".".4N
QUIT 1_U_"Appt Date/Time error: "_$GET(BSDR("ADT"))
+23 ;remove seconds
IF $GET(BSDR("CDT"))
SET BSDR("CDT")=+$EXTRACT(BSDR("CDT"),1,12)
+24 IF $GET(BSDR("CDT"))'?7N1".".4N
QUIT 1_U_"Cancel Date/Time error: "_$GET(BSDR("CDT"))
+25 IF '$DATA(^VA(200,+$GET(BSDR("USR")),0))
QUIT 1_U_"User Who Canceled Appt Error: "_$GET(BSDR("USR"))
+26 IF '$DATA(^SD(409.2,+$GET(BSDR("CR"))))
QUIT 1_U_"Cancel Reason error: "_$GET(BSDR("CR"))
+27 ;
+28 NEW IEN,DIE,DA,DR
+29 SET IEN=$$SCIEN^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
+30 IF 'IEN
QUIT 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
+31 ;
+32 IF $$CI^BSDU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN)
QUIT 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
+33 ;
+34 ; remember before status
+35 NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
+36 SET DFN=BSDR("PAT")
SET SDT=BSDR("ADT")
SET SDCL=BSDR("CLN")
SET SDMODE=2
SET SDDA=IEN
+37 SET SDCPHDL=$$HANDLE^SDAMEVT(1)
SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+38 DO BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
+39 ;
+40 ; get user who made appt and date appt made from ^SC
+41 ; because data in ^SC will be deleted
+42 NEW USER,DATE
+43 SET USER=$PIECE($GET(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
+44 SET DATE=$PIECE($GET(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
+45 ;
+46 ; update file 2 info
+47 NEW DIE,DA,DR
+48 SET DIE="^DPT("_DFN_",""S"","
SET DA(1)=DFN
SET DA=SDT
+49 SET DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
+50 IF $GET(BSDR("NOT"))]""
SET DR=DR_";17///"_$EXTRACT(BSDR("NOT"),1,160)
+51 DO ^DIE
+52 ;
+53 ; delete data in ^SC
+54 NEW DIK,DA
+55 SET DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
+56 SET DA(2)=BSDR("CLN")
SET DA(1)=BSDR("ADT")
SET DA=IEN
+57 DO ^DIK
+58 QUIT 0
+59 ;
APPUDEL(BSDXY,BSDXAPTID) ;EP Undo Cancel
+1 ;called by BSDX UNCANCEL APPT
+2 ; BSDXAPTID = ien of appointment in BSDX APPOINTMENT (^BSDXAPPT) file 9002018.4
+3 NEW BSDXDAM,BSDXDEC,BSDXI,BSDXNOD,BSDXPATID,BSDXSTART
+4 ;Don't execute BSDX CANCEL APPOINTMENT protocol
SET BSDXNOEV=1
+5 ;
+6 DO ^XBKVAR
SET X="ETRAP^BSDX08"
SET @^%ZOSF("TRAP")
+7 SET BSDXI=0
+8 KILL ^BSDXTMP($JOB)
+9 SET BSDXY="^BSDXTMP("_$JOB_")"
+10 SET ^BSDXTMP($JOB,BSDXI)="T00020ERRORID"_$CHAR(30)
+11 TSTART
+12 IF '+BSDXAPTID
TROLLBACK
DO ERR(BSDXI+1,"Invalid Appointment ID.")
QUIT
+13 IF '$DATA(^BSDXAPPT(BSDXAPTID,0))
TROLLBACK
DO ERR(BSDXI+1,"Invalid Appointment ID")
QUIT
+14 ;Make sure appointment is cancelled
+15 IF $$GET1^DIQ(9002018.4,BSDXAPTID_",",.12)=""
TROLLBACK
DO ERR(BSDXI+1,"Appointment is not Cancelled.")
QUIT
+16 ;appts cancelled by patient cannot be uncancelled.
+17 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+18 IF $PIECE(^DPT($PIECE(BSDXNOD,U,5),"S",$PIECE(BSDXNOD,U,1),0),U,2)="PC"
TROLLBACK
DO ERR(BSDXI+1,"Cancelled by patient appointment can not be uncancelled.")
QUIT
+19 ;get appointment data
+20 SET BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
+21 ;date appt made
SET BSDXDAM=$PIECE(BSDXNOD,U,9)
+22 ;data entry clerk
SET BSDXDEC=$PIECE(BSDXNOD,U,8)
+23 ;length of appt in minutes
SET BSDXLEN=$PIECE(BSDXNOD,U,18)
+24 ;note from BSDX APPOINTMENT
SET BSDXNOTE=$GET(^BSDXAPPT(BSDXAPTID,1,1,0))
+25 ;pointer to VA PATIENT file 2
SET BSDXPATID=$PIECE(BSDXNOD,U,5)
+26 ;resource
SET BSDXSC1=$PIECE($GET(BSDXNOD),U,7)
+27 ;appt start time
SET BSDXSTART=$PIECE(BSDXNOD,U)
+28 ;walkin
SET BSDXWKIN=$PIECE($GET(BSDXNOD),U,13)
+29 ;lock BSDX node
+30 LOCK +^BSDXAPPT(BSDXPATID):5
IF '$TEST
DO ERR(BSDXI+1,"Another user is working with this patient's record. Please try again later")
TROLLBACK
QUIT
+31 ;uncancel BSDX APPOINTMENT
+32 DO BSDXUCAN(BSDXAPTID)
+33 IF BSDXSC1]""
IF $DATA(^BSDXRES(BSDXSC1,0))
Begin DoDot:1
+34 SET BSDXNOD=^BSDXRES(BSDXSC1,0)
+35 ;HOSPITAL LOCATION
SET BSDXLOC=$PIECE(BSDXNOD,U,4)
+36 IF '+BSDXLOC
QUIT
+37 ;uncancel patient appointment and re-instate clinic appointment
+38 SET BSDXZ=""
+39 DO APUCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXSC1,BSDXWKIN)
End DoDot:1
IF +$GET(BSDXZ)
SET BSDXERR=BSDXERR_$PIECE(BSDXZ,U,2)
DO ERR(BSDXI,BSDXERR)
QUIT
+40 TCOMMIT
+41 LOCK -^BSDXAPPT(BSDXPATID)
+42 SET BSDXI=BSDXI+1
+43 SET ^BSDXTMP($JOB,BSDXI)=""_$CHAR(30)
+44 SET BSDXI=BSDXI+1
+45 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+46 QUIT
+47 ;
BSDXUCAN(BSDXAPTID) ;called internally to update BSDX APPOINTMENT by clearing cancel date/time
+1 SET BSDXIENS=BSDXAPTID_","
+2 SET BSDXFDA(9002018.4,BSDXIENS,.12)=""
+3 KILL BSDXMSG
+4 DO FILE^DIE("","BSDXFDA","BSDXMSG")
+5 QUIT
+6 ;
APUCAN(BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART,BSDXDAM,BSDXDEC,BSDXLEN,BSDXNOTE,BSDXRES,BSDXWKIN) ;
+1 ;unCancel appointment for patient BSDXDFN in clinic BSDXSC1
+2 ; BSDXLOC = pointer to hospital location ^SC file 44
+3 ; BSDXPATID = pointer to VA Patient ^DPT file 2
+4 ; BSDXSTART = Appointment time
+5 ; BSDXDAM = Date appointment made in FM format
+6 ; BSDXDEC = Data entry clerk - pointer to NEW PERSON file 200
+7 NEW BSDXC,%H
+8 SET BSDXC("PAT")=BSDXPATID
+9 SET BSDXC("CLN")=BSDXLOC
+10 SET BSDXC("ADT")=BSDXSTART
+11 ;user note
SET BSDXC("NOTE")=BSDXNOTE
+12 SET BSDXC("RES")=BSDXRES
+13 SET BSDXC("USR")=DUZ
+14 SET BSDXC("LEN")=BSDXLEN
+15 SET BSDXC("WKIN")=BSDXWKIN
+16 ;
+17 SET BSDXZ=$$UNCANCEL(.BSDXC)
+18 QUIT
+19 ;
UNCANCEL(BSDR) ;PEP; called to ucancel appt
+1 ;
+2 ; Make call using: S ERR=$$UNCANCEL(.ARRAY)
+3 ;
+4 ; Input Array -
+5 ; BSDR("PAT") = ien of patient in file 2
+6 ; BSDR("CLN") = ien of clinic in file 44
+7 ; BSDR("ADT") = appointment date and time
+8 ; BSDR("USR") = user who uncanceled appt
+9 ; BSDR("NOTE") = appointment note from BSDX APPOINTMENT
+10 ; BSDR("LEN") = appt length in minutes (numeric)
+11 ; BSDR("RES") = resource
+12 ; BSDR("WKIN")= walkin
+13 ;
+14 ;Output: error status and message
+15 ; = 0 or null: everything okay
+16 ; = 1^message: error and reason
+17 ;
+18 NEW DPTNOD,DPTNODR
+19 IF '$DATA(^DPT(+$GET(BSDR("PAT")),0))
QUIT 1_U_"Patient not on file: "_$GET(BSDR("PAT"))
+20 IF '$DATA(^SC(+$GET(BSDR("CLN")),0))
QUIT 1_U_"Clinic not on file: "_$GET(BSDR("CLN"))
+21 ;remove seconds
IF $GET(BSDR("ADT"))
SET BSDR("ADT")=+$EXTRACT(BSDR("ADT"),1,12)
+22 IF $GET(BSDR("ADT"))'?7N1".".4N
QUIT 1_U_"Appt Date/Time error: "_$GET(BSDR("ADT"))
+23 IF '$DATA(^VA(200,+$GET(BSDR("USR")),0))
QUIT 1_U_"User Who Canceled Appt Error: "_$GET(BSDR("USR"))
+24 ;
+25 SET BSDXERR=$$APPRPMS^BSDX07(BSDR("LEN"),BSDR("NOTE"),BSDR("PAT"),BSDR("RES"),BSDR("ADT"),BSDR("WKIN"))
+26 QUIT BSDXERR
+27 ;
ERR(BSDXI,BSDXERR) ;Error processing
+1 SET BSDXI=BSDXI+1
+2 SET BSDXERR=$TRANSLATE(BSDXERR,"^","~")
+3 TROLLBACK
+4 SET ^BSDXTMP($JOB,BSDXI)=BSDXERR_$CHAR(30)
+5 SET BSDXI=BSDXI+1
+6 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+7 LOCK
+8 QUIT
+9 ;
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 IF '$DATA(BSDXI)
NEW BSDXI
SET BSDXI=999999
+3 SET BSDXI=BSDXI+1
+4 DO ERR(BSDXI,"BSDX08 Error: "_$GET(%ZTERROR))
+5 QUIT
