SDEC08 ;ALB/SAT/JSM,WTC,LAB,LEG,RRM,MGD,BLB,JAS,BLB - DELETE APPTS ;Apr 1, 2024
;;5.3;Scheduling;**627,651,658,665,722,740,744,694,745,756,774,781,785,790,792,796,797,799,801,805,819,842,832,851,873,875,877**;Aug 13, 1993;Build 14
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^DPT (Patient File) is supported by IA #7030
Q
;
APPDEL(SDECY,SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SOURCE,SDF,SDECCMT,NEWPID,EASTRCKNGNMBR) ;Cancels appointment
;SDECAPTID - (required) pointer to SDEC APPOINTMENT file #409.84
;SDECTYP - (required) appointment Status valid values:
; C=CANCELLED BY CLINIC
; PC=CANCELLED BY PATIENT
;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
;SDECNOT - (optional) text representing user note
;SDECDATE - (optional) Cancel Date/Time in external format; defaults to NOW
;SDUSER - (optional) User that cancelled appt; defaults to current user
;SOURCE - future enhancement L 1.8 SD*5.3*715
;SDF - (optional) Flag to determine whether to reopen appointment SD*5.3*745
;SDECCMT - (optional) List of cancellation comment hash tags (see #409.88) separated by ^ - 756 6/8/2020 wtc
;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
;Returns error code in record set field ERRORID
;
N SDECNOD,SDECPATID,SDECSTART,DIK,DA,SDECID,SDECI,SDECZ,SDECERR
N SDECLOC,SDECLEN,SDECSCIEN,SDECSCIEN1,SDECNOEV,SDECSC1,SDRET
N %DT,X,Y,SDECJ ; wtc 756 6/8/2020 added SDECJ
S NEWPID=$G(NEWPID)
I $G(NEWPID)'="" D
.S NEWPID=$$NETTOFM^SDECDATE(NEWPID,"N","N")
S SDF=$S($G(SDF)=3:3,$G(SDF)=2:2,1:1) ; lab 745 default all flags to 1 except a flag of 2.
S SDECNOEV=1 ;Don't execute SDEC CANCEL APPOINTMENT protocol
S SDECSCIEN1=0
;
S SDECI=0
S SDECY="^TMP(""SDEC08"","_$J_",""APPDEL"")"
K @SDECY
S @SDECY@(SDECI)="T00020ERRORID"_$C(30)
S SDECI=SDECI+1
;validate SDEC APPOINTMENT pointer (required)
I '$D(^SDEC(409.84,+$G(SDECAPTID),0)) D ADERR(SDECI,.SDECY,"SDEC08: Invalid Appointment ID",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740 added ADERR
;verify unique PID for MRTCs
I NEWPID N DUPERR D Q:$G(DUPERR)
. S DUPERR=0
. N APPTREQTYPE,REQUESTIEN
. S APPTREQTYPE=$$GET1^DIQ(409.84,+$G(SDECAPTID),.22,"I")
. S REQUESTIEN=$P($G(APPTREQTYPE),";")
. I $$DUPPIDCHK^SDES2CANCELAPPT(REQUESTIEN,NEWPID) D
. . S DUPERR=1 D ADERR(SDECI,.SDECY,"SDEC08: PID date already used on another associated child record",+$G(SDECAPTID),0)
;validate appointment status type (required)
S SDECTYP=$G(SDECTYP)
S SDECTYP=$S(SDECTYP="C":"C",SDECTYP="CANCELLED BY CLINIC":"C",SDECTYP="PC":"PC",SDECTYP="CANCELLED BY PATIENT":"PC",1:"")
I SDECTYP="" D ADERR(SDECI,.SDECY,"SDEC08: Invalid status type",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740 added ADERR
;validate CANCELLATION REASON pointer (optional)
S SDECCR=$G(SDECCR)
I SDECCR'="" I '$D(^SD(409.2,+SDECCR,0)) S SDECCR=$O(^SD(409.2,"B",SDECCR,0)) ;832
;validate SDECNOT
S SDECNOT=$TR($G(SDECNOT),"^"," ") ;alb/sat 658 - strip out ^
;
; Add cancellation comment HASHTAGs from #409.88 to beginning of user note. - 756 wtc 6/8/2020
;
I $G(SDECCMT)'="" F SDECJ=$L(SDECCMT,U):-1:1 S SDECNOT=$P(SDECCMT,U,SDECJ)_"_"_SDECNOT ; Add hashtags in reverse order of receipt so national appear first. wtc 8/19/2020
I $E(SDECNOT,$L(SDECNOT))="_" S SDECNOT=$E(SDECNOT,1,$L(SDECNOT)-1) ; Strip off trailing "_". Happens if not extra note text.
;
;validate cancel date/time
S SDECDATE=$G(SDECDATE)
;
; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
;
;I SDECDATE'="" S %DT="T" S X=SDECDATE D ^%DT S SDECDATE=Y I Y=-1 S SDECDATE=""
I SDECDATE'="" S SDECDATE=$$NETTOFM^SDECDATE(SDECDATE,"Y","N") I SDECDATE=-1 S SDECDATE="" ; wtc 6/18/18
I $G(SDECDATE)="" S SDECDATE=$$NOW^XLFDT
;validate user
S SDUSER=$G(SDUSER)
I SDUSER'="" I '$D(^VA(200,+SDUSER,0)) S SDUSER=""
I SDUSER="" S SDUSER=DUZ
;Delete APPOINTMENT entries
S SDECNOD=^SDEC(409.84,SDECAPTID,0)
S SDECPATID=$P(SDECNOD,U,5)
S SDECSTART=$P(SDECNOD,U)
;
;Lock SDEC node
;changed SDECPATID to SDECAPTID to get APPOINTMENT ID instead of PATIENT ID ; pwc *745 7/16/2020
L +^SDEC(409.84,SDECAPTID):5 I '$T D ADERR(SDECI+1,.SDECY,"Another user is working with this patient's record. Please try again later",+SDECAPTID,0) Q ;BI/SD *5.3*740
;cancel check-in if walk-in
I $P(SDECNOD,U,13)="y" D
.S SDRET=""
.D CHECKIN^SDEC25(.SDRET,SDECAPTID,"@")
;validate EAS Tracking Number
S EASTRCKNGNMBR=$TR($G(EASTRCKNGNMBR),"^"," ")
I $L(EASTRCKNGNMBR) S EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
I EASTRCKNGNMBR=-1 D ADERR(SDECI,.SDECY,"SDEC08: Invalid EAS Tracking Number",+$G(SDECAPTID),0) Q
;cancel SDEC APPOINTMENT record
D SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,$G(NEWPID),EASTRCKNGNMBR) ;*745
;
S SDECSC1=$P(SDECNOD,U,7) ;RESOURCEID
I SDECSC1]"",$D(^SDEC(409.831,SDECSC1,0)) D I +$G(SDECZ) S SDECERR=+SDECZ D ADERR(SDECI,.SDECY,$P(SDECZ,U,2),+SDECAPTID,1) Q ;BI/SD*5.3*740 added ADERR ;changed SDECPATID to SDECAPTID - pwc *745
. S SDECNOD=^SDEC(409.831,SDECSC1,0)
. S SDECLOC=$P(SDECNOD,U,4) ;HOSPITAL LOCATION
. Q:'+SDECLOC
. S SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART) I SDECSCIEN="" D I 'SDECZ Q ;Q:SDECZ
.. S SDECERR="SDEC08: Unable to find associated appointment for this patient. "
.. S SDECZ=1 I '$D(^SDEC(409.831,SDECSC1,20)) S SDECZ=0 Q
.. N SDEC1 S SDEC1=0
.. F S SDEC1=$O(^SDEC(409.831,SDECSC1,20,SDEC1)) Q:'+SDEC1 Q:SDECZ=0 D
... Q:'$D(^SDEC(409.831,SDECSC1,20,SDEC1,0))
... S SDECLOC=$P(^SDEC(409.831,SDECSC1,20,SDEC1,0),U)
... S SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART) I +SDECSCIEN S SDECZ=0 Q
. S SDECERR="SDEC08: CANCEL^SDEC08 Returned "
. I SDECLOC']"" S SDECZ="0^Unable to find associated appointment for this patient." Q
. I '$D(^SC(SDECLOC,0)) S SDECZ="0^Unable to find associated appointment for this patient." Q
. S SDECNOD=$G(^SC(SDECLOC,"S",SDECSTART,1,+SDECSCIEN,0))
. I SDECNOD="" S SDECZ="0^Unable to find associated appointment for this patient." Q
. S SDECLEN=$P(SDECNOD,U,2)
. D APCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECAPTID,SDECLEN)
. Q:+$G(SDECZ)
. D AVUPDT^SDEC08A(SDECLOC,SDECSTART,SDECLEN) ;moved to SDEC08A routine is too big *745
. D AR433D^SDECAR2(SDECAPTID)
L -^SDEC(409.84,SDECAPTID) ;changed SDECPATID to SDECAPTID ; pwc *745
S SDECI=SDECI+1
S @SDECY@(SDECI)=""_$C(30)
S SDECI=SDECI+1
S @SDECY@(SDECI)=$C(31)
Q
;
ADERR(SDECI,SDECY,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID ; pwc *745
S SDECI=SDECI+1
S SDECERR=$TR(SDECERR,"^","~")
S @SDECY@(SDECI)=SDECERR_$C(30)
S SDECI=SDECI+1
S @SDECY@(SDECI)=$C(31)
I LOCK=1 L -^SDEC(409.84,SDECAPTID) ; changed SDECPATID to SDECAPTID ; pwc *745
Q
;
SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,NEWPID,EASTRCKNGNMBR) ;cancel SDEC APPOINTMENT entry
;SDECAPTID - (required) pointer to SDEC APPOINTMENT file
;SDECTYP - (required) appointment Status valid values:
; C=CANCELLED BY CLINIC
; PC=CANCELLED BY PATIENT
;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
;SDECNOT - (optional) text representing user note
;SDECDATE - (optional) Cancel Date/Time in fm format; defaults to NOW) ;
;SDF - (optional) flags ;*745 expanded flag explanation
; "1" or null - update consult only. (assumption called from a GUI)
; "01" (two digit) -do not reopen appt (called from cancel in SDAM)
; "2" - close appt request disp code REMOVED/EXTERNAL APP
; "3" - Block & Move don't re-open a Appt Request if a Recall
;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
;
;Cancel SDEC APPOINTMENT entry
N DFN,PROVIEN,Y
N SAVESTRT,SDAPTYP,SDCL,SDI,SDIEN,SDECIENS,SDECFDA,SDECMSG,SDECWP,SDRES,SDT ;alb/sat 651 add SAVESTRT and SDRES
N DFN40985,IEN40986,PIDCHANGEVERIF,CSFDA,CSSIEN,ERR,CONSIEN,PIDHIEN,SDRESTPOST ;**792
S SDF=$G(SDF,0)
S NEWPID=$G(NEWPID)
S DFN=$$GET1^DIQ(409.84,SDECAPTID_",",.05,"I") ;alb/sat 658;781 lab added, "I"
S SDT=$$GET1^DIQ(409.84,SDECAPTID_",",.01,"I")
S SAVESTRT=$$GET1^DIQ(409.84,SDECAPTID_",",.01) ;alb/sat 651
S SDRES=$$GET1^DIQ(409.84,SDECAPTID_",",.07,"I") ;alb/sat 651
S SDECIENS=SDECAPTID_","
S SDECFDA(409.84,SDECIENS,.12)=$S($G(SDECDATE)'="":SDECDATE,1:$$NOW^XLFDT)
S SDECFDA(409.84,SDECIENS,.121)=$S($G(SDUSER)'="":SDUSER,1:DUZ)
S:$G(SDECCR)'="" SDECFDA(409.84,SDECIENS,.122)=SDECCR
S SDECFDA(409.84,SDECIENS,.17)=SDECTYP
;S SDECFDA(409.84,SDECIENS,2)="@" ;patch SD*5.3*796, delete VVS appointment ID if appointment is cancelled
S:$G(EASTRCKNGNMBR)'="" SDECFDA(409.84,SDECIENS,100)=EASTRCKNGNMBR
K SDECMSG
D FILE^DIE("","SDECFDA","SDECMSG")
S SDAPTYP=$$GET1^DIQ(409.84,SDECAPTID_",",.22,"I")
I SDF=3,$P(SDAPTYP,";",2)'="SD(403.5," S SDF=0
;alb/sat 658 modification begin
S SDECNOT=$G(SDECNOT) ;,SDECNOT=$E(SDECNOT,1,160) - removed 160 character restriction so entire note is stored in #409.84 - wtc 756
I $L(SDECNOT)>2,'$E(SDF,2) K SDECFDA
S SDECFDA(2.98,SDT_","_DFN_",",17)=$E(SDECNOT,1,160) D UPDATE^DIE("","SDECFDA") ; restrict note in #2 to 160 characters - wtc 756
; VSE-863; 6/6/2021 ; create new "APPT" Request if A "RECALL" Appt is Cancelled
I $P(SDAPTYP,";",2)="SD(403.5," D Q
.Q:SDF=3
.D RECREQ^SDECRECREQ(.SDECY,SDECAPTID,SDAPTYP,$G(NEWPID),$G(SDECTYP))
;alb/sat 658 modification end
I $P(SDAPTYP,";",2)="GMR(123,",$E(SDF,1),(SDF'=2) D
.S SDCL=$$SDCL^SDECUTL(SDECAPTID)
.S PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
.D REQSET^SDEC07A($P(SDAPTYP,";",1),PROVIEN,"",2,SDECTYP,SDECNOT,SAVESTRT,SDRES) ;651 added SAVESTRT
.I $G(NEWPID) D
..S CONSIEN=$P(SDAPTYP,";",1)
..S PIDHIEN=$O(^SDEC(409.87,"B",CONSIEN,0))
..S CSFDA(409.871,"+1,"_PIDHIEN_",",.01)=$$NOW^XLFDT
..S CSFDA(409.871,"+1,"_PIDHIEN_",",1)=$G(NEWPID)
..S CSFDA(409.871,"+1,"_PIDHIEN_",",2)=$$GET1^DIQ(200,SDUSER,.01,"E")
..D UPDATE^DIE("","CSFDA","CSSIEN","ERR") K CSFDA
;
I $P(SDAPTYP,";",2)="SDEC(409.85," D ;update APPT
.K SDECFDA,SDECMSG,SDECWP
.D:'$E(SDF,2) AROPEN^SDECAR("",SDECAPTID)
.S SDIEN=$P(SDAPTYP,";",1)
.S SDECFDA(409.85,SDIEN_",",13)="@"
.S SDECFDA(409.85,SDIEN_",",13.1)="@"
.S SDECFDA(409.85,SDIEN_",",13.2)="@"
.S SDECFDA(409.85,SDIEN_",",13.3)="@"
.S SDECFDA(409.85,SDIEN_",",13.4)="@"
.S SDECFDA(409.85,SDIEN_",",13.5)="@"
.S SDECFDA(409.85,SDIEN_",",13.6)="@"
.S SDECFDA(409.85,SDIEN_",",13.7)="@"
.S SDECFDA(409.85,SDIEN_",",13.8)="@"
.S PIDCHANGEVERIF=$S(SDECTYP="C":0,SDECTYP="PC":1,1:"")
.S SDECFDA(409.85,SDIEN_",",49)=PIDCHANGEVERIF
.S:$G(EASTRCKNGNMBR)'="" SDECFDA(409.85,SDIEN_",",100)=EASTRCKNGNMBR
.; If Canc Don't Re-Open and no existing Disp Code
.I ($$GET1^DIQ(409.2,SDECCR,5,"I")=0),($$GET1^DIQ(409.85,SDIEN,21,"I")="") D
..S SDECFDA(409.85,SDIEN_",",19)=$P($$GET1^DIQ(409.84,SDECAPTID,.12,"I"),".",1)
..S SDECFDA(409.85,SDIEN_",",20)=$$GET1^DIQ(409.84,SDECAPTID,.121,"I")
..S SDECFDA(409.85,SDIEN_",",21)=$O(^SDEC(409.853,"B","CANCELLED NOT RE-OPENED",""))
.D UPDATE^DIE("","SDECFDA","ARRET","ERRMSG")
.I SDF=2 NEW INP S INP(1)=SDIEN S INP(2)="REMOVED/EXTERNAL APP" S INP(3)=SDUSER S INP(4)=DT D ARCLOSE^SDECAR("",.INP) ;*745
Q
;
CANEVT(SDECPAT,SDECSTART,SDECSC) ;EP Called by SDEC CANCEL APPOINTMENT
;when Appt cancelled via PIMS interface.
;Propagates cancel to SDECAPPT & raises refresh event to running GUI clients
N SDECFOUND,SDECRES
Q:+$G(SDECNOEV)
Q:'+$G(SDECSC)
S SDECFOUND=0
I $D(^SDEC(409.831,"ALOC",SDECSC)) S SDECRES=$O(^SDEC(409.831,"ALOC",SDECSC,0)) S SDECFOUND=$$CANEVT1(SDECRES,SDECSTART,SDECPAT)
I SDECFOUND D CANEVT3(SDECRES) Q
Q
;
CANEVT1(SDECRES,SDECSTART,SDECPAT) ;
;Get Appt ID in SDECAPT
;If found, call SDECCAN(SDECAPPT) and return 1
;else return 0
N SDECFOUND,SDECAPPT
S SDECFOUND=0
Q:'+SDECRES SDECFOUND
Q:'$D(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART)) SDECFOUND
S SDECAPPT=0 F S SDECAPPT=$O(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART,SDECAPPT)) Q:'+SDECAPPT D Q:SDECFOUND
. S SDECNOD=$G(^SDEC(409.84,SDECAPPT,0)) Q:SDECNOD=""
. I $P(SDECNOD,U,5)=SDECPAT,$P(SDECNOD,U,12)="" S SDECFOUND=1 Q
I SDECFOUND,+$G(SDECAPPT) D SDECCAN(SDECAPPT,,,,,,1)
Q SDECFOUND
;
CANEVT3(SDECRES) ;
;Call RaiseEvent to notify GUI clients
Q
N SDECRESN
S SDECRESN=$G(^SDEC(409.831,SDECRES,0))
Q:SDECRESN=""
S SDECRESN=$P(SDECRESN,"^")
Q
;
CANCEL(BSDR) ;EP; called to cancel appt
; Make call using: S ERR=$$CANCEL^SDEC08(.ARRAY)
;
; Input Array -
; BSDR("PAT") = ien of patient file 2
; BSDR("CLN") = ien of clinic 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"))'?7N1"."1N.N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT")) ;PWC allow any time combination of numbers #694
I $G(BSDR("CDT"))'?7N1"."1N.N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT")) ;PWC allow any time combination of numbers #694
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,SDMODE,HLAPTIEN ;*zeb+1 722 2/21/19 save IEN for canceling appt
S IEN=$$SCIEN^SDECU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT")),HLAPTIEN=IEN
I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
;
I $$CI^SDECU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Patient already checked in; cannot cancel until check-in 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
N SDFDA,SDIEN,SDMSG
S SDFDA="SDFDA(2.98,SDT_"",""_DFN_"","")"
S @SDFDA@(3)=BSDR("TYP")
S @SDFDA@(14)=BSDR("USR")
S @SDFDA@(15)=BSDR("CDT")
S:+$G(BSDR("CR")) @SDFDA@(16)=BSDR("CR")
S:$G(BSDR("NOT"))]"" @SDFDA@(17)=$E(BSDR("NOT"),1,160)
S @SDFDA@(19)=USER
S @SDFDA@(20)=DATE
D UPDATE^DIE("","SDFDA") ; ICR #7030 wtc 756 6/15/2020
N SDPCE
S SDPCE=$P($G(^DPT(DFN,"S",SDT,0)),U,20) ; ICR #7030 wtc 756 6/15/2020
D:+SDPCE EN^SDCODEL(SDPCE,2,"","CANCEL") ;remove OUTPATIENT ENCOUNTER link ;*zeb 10/25/18 722 pass in correct SDMODE and delete source
S $P(^SC(BSDR("CLN"),"S",BSDR("ADT"),1,HLAPTIEN,0),"^",9)="C"
; call event driver
S SDATA=SDDA_U_DFN_U_SDT_U_SDCL
D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL) ;*zeb 10/25/18 722 uncomment to re-enable event driver
Q 0
;
UNDOCANA(SDECY,SDECAPTID) ;Undo Cancel Appointment
;UNDOCANA(SDECY,SDECAPTID) external parameter tag in SDEC
;called by SDEC UNCANCEL APPT
; SDECAPTID = ien of appointment in SDEC APPOINTMENT (^SDECAPPT) file 409.84
N SDECDAM,SDECDEC,SDECI,SDECNOD,SDECPATID,SDECSTART,SDECNOTE,SDECWKIN
S SDECNOEV=1 ;Don't execute SDEC CANCEL APPOINTMENT protocol ;is this used?
;
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,SDECI)="T00020ERRORID"_$C(30)
I '+SDECAPTID D ERR(SDECI+1,"Invalid Appointment ID.",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740
I '$D(^SDEC(409.84,SDECAPTID,0)) D ERR(SDECI+1,"Invalid Appointment ID",+SDECAPTID,0) Q ;BI/SD*5.3*740
;Make sure appointment is cancelled
I $$GET1^DIQ(409.84,SDECAPTID_",",.12)="" D ERR(SDECI+1,"Appointment is not Cancelled.",+SDECAPTID,0) Q ;BI/SD*5.3*740
S SDECNOD=^SDEC(409.84,SDECAPTID,0)
;appts cancelled by patient cannot be un-cancelled. /* removed 9/17/2010 */
;I $P(^DPT($P(SDECNOD,U,5),"S",$P(SDECNOD,U,1),0),U,2)="PC" TROLLBACK D ERR(SDECI+1,"Cancelled by patient appointment cannot be uncancelled.") Q
;get appointment data
S SDECNOD=^SDEC(409.84,SDECAPTID,0)
S SDECDAM=$P(SDECNOD,U,9) ;date appt made
S SDECDEC=$P(SDECNOD,U,8) ;data entry clerk
S SDECLEN=$P(SDECNOD,U,18) ;length of appt in minutes
;
; Get entire note from Appointment file. 756 wtc 1/25/2019
;
;S SDECNOTE=$G(^SDEC(409.84,SDECAPTID,1,1,0)) ;note from SDEC APPOINTMENT
S SDECNOTE="" N I F I=1:1 Q:'$D(^SDEC(409.84,SDECAPTID,1,I,0)) S SDECNOTE=SDECNOTE_^(0)_$C(13) ;
;
S SDECPATID=$P(SDECNOD,U,5) ;pointer to VA PATIENT file 2
S SDECSC1=$P($G(SDECNOD),U,7) ;resource
S SDECSTART=$P(SDECNOD,U) ;appt start time
S SDECWKIN=$P($G(SDECNOD),U,13) ;walk-in
;lock SDEC node
; changed line below to use SDECAPTID instead of SDECPATID ; pwc *745 7/16/2020
L +^SDEC(409.84,SDECAPTID):5 I '$T D ERR(SDECI+1,"Another user is working with this patient's record. Please try again later",+SDECAPTID,0) Q ;BI/SD*5.3*740
;un-cancel SDEC APPOINTMENT
D SDECUCAN^SDEC08A(SDECAPTID) ;moved to ^SDEC08A because of XINDEX size *756 PWC
I SDECSC1]"",$D(^SDEC(409.831,SDECSC1,0)) D I +$G(SDECZ) S SDECERR=SDECERR_$P(SDECZ,U,2) D ERR(SDECI,SDECERR,+SDECAPTID,1) Q ;BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID - pwc *745
. S SDECLOC=""
. S SDECNOD=^SDEC(409.831,SDECSC1,0)
. S SDECLOC=$P(SDECNOD,U,4) ;HOSPITAL LOCATION ;support for single HOSPITAL LOCATION in SDEC RESOURCE
. I SDECLOC="" S SDECLOC=$$SDCL^SDECUTL(SDECAPTID) ;HOSPITAL LOCATION
. Q:'+SDECLOC
. ;un-cancel patient appointment and re-instate clinic appointment
. S SDECZ=""
. D APUCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECDAM,SDECDEC,SDECLEN,SDECNOTE,SDECSC1,SDECWKIN) ;moved to ^SDEC08A because of XINDEX size *756 PWC
L -^SDEC(409.84,SDECAPTID) ;changed SDECPATID to SDECAPTID - pwc *745
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=""_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
;
ERR(SDECI,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 added two parameters ;changed SDECPATID to SDECAPTID - pwc *745
S SDECI=SDECI+1
S SDECERR=$TR(SDECERR,"^","~")
S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=$C(31)
I $G(LOCK)=1 L -^SDEC(409.84,SDECAPTID) ;BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID - pwc *745
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
I '$D(SDECI) N SDECI S SDECI=999999
S SDECI=SDECI+1
D ERR(SDECI,"SDEC08 Error")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC08 19726 printed Nov 22, 2024@18:00:02 Page 2
SDEC08 ;ALB/SAT/JSM,WTC,LAB,LEG,RRM,MGD,BLB,JAS,BLB - DELETE APPTS ;Apr 1, 2024
+1 ;;5.3;Scheduling;**627,651,658,665,722,740,744,694,745,756,774,781,785,790,792,796,797,799,801,805,819,842,832,851,873,875,877**;Aug 13, 1993;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^DPT (Patient File) is supported by IA #7030
+5 QUIT
+6 ;
APPDEL(SDECY,SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SOURCE,SDF,SDECCMT,NEWPID,EASTRCKNGNMBR) ;Cancels appointment
+1 ;SDECAPTID - (required) pointer to SDEC APPOINTMENT file #409.84
+2 ;SDECTYP - (required) appointment Status valid values:
+3 ; C=CANCELLED BY CLINIC
+4 ; PC=CANCELLED BY PATIENT
+5 ;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
+6 ;SDECNOT - (optional) text representing user note
+7 ;SDECDATE - (optional) Cancel Date/Time in external format; defaults to NOW
+8 ;SDUSER - (optional) User that cancelled appt; defaults to current user
+9 ;SOURCE - future enhancement L 1.8 SD*5.3*715
+10 ;SDF - (optional) Flag to determine whether to reopen appointment SD*5.3*745
+11 ;SDECCMT - (optional) List of cancellation comment hash tags (see #409.88) separated by ^ - 756 6/8/2020 wtc
+12 ;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
+13 ;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
+14 ;Returns error code in record set field ERRORID
+15 ;
+16 NEW SDECNOD,SDECPATID,SDECSTART,DIK,DA,SDECID,SDECI,SDECZ,SDECERR
+17 NEW SDECLOC,SDECLEN,SDECSCIEN,SDECSCIEN1,SDECNOEV,SDECSC1,SDRET
+18 ; wtc 756 6/8/2020 added SDECJ
NEW %DT,X,Y,SDECJ
+19 SET NEWPID=$GET(NEWPID)
+20 IF $GET(NEWPID)'=""
Begin DoDot:1
+21 SET NEWPID=$$NETTOFM^SDECDATE(NEWPID,"N","N")
End DoDot:1
+22 ; lab 745 default all flags to 1 except a flag of 2.
SET SDF=$SELECT($GET(SDF)=3:3,$GET(SDF)=2:2,1:1)
+23 ;Don't execute SDEC CANCEL APPOINTMENT protocol
SET SDECNOEV=1
+24 SET SDECSCIEN1=0
+25 ;
+26 SET SDECI=0
+27 SET SDECY="^TMP(""SDEC08"","_$JOB_",""APPDEL"")"
+28 KILL @SDECY
+29 SET @SDECY@(SDECI)="T00020ERRORID"_$CHAR(30)
+30 SET SDECI=SDECI+1
+31 ;validate SDEC APPOINTMENT pointer (required)
+32 ;BI/SD*5.3*740 added ADERR
IF '$DATA(^SDEC(409.84,+$GET(SDECAPTID),0))
DO ADERR(SDECI,.SDECY,"SDEC08: Invalid Appointment ID",+$GET(SDECAPTID),0)
QUIT
+33 ;verify unique PID for MRTCs
+34 IF NEWPID
NEW DUPERR
Begin DoDot:1
+35 SET DUPERR=0
+36 NEW APPTREQTYPE,REQUESTIEN
+37 SET APPTREQTYPE=$$GET1^DIQ(409.84,+$GET(SDECAPTID),.22,"I")
+38 SET REQUESTIEN=$PIECE($GET(APPTREQTYPE),";")
+39 IF $$DUPPIDCHK^SDES2CANCELAPPT(REQUESTIEN,NEWPID)
Begin DoDot:2
+40 SET DUPERR=1
DO ADERR(SDECI,.SDECY,"SDEC08: PID date already used on another associated child record",+$GET(SDECAPTID),0)
End DoDot:2
End DoDot:1
if $GET(DUPERR)
QUIT
+41 ;validate appointment status type (required)
+42 SET SDECTYP=$GET(SDECTYP)
+43 SET SDECTYP=$SELECT(SDECTYP="C":"C",SDECTYP="CANCELLED BY CLINIC":"C",SDECTYP="PC":"PC",SDECTYP="CANCELLED BY PATIENT":"PC",1:"")
+44 ;BI/SD*5.3*740 added ADERR
IF SDECTYP=""
DO ADERR(SDECI,.SDECY,"SDEC08: Invalid status type",+$GET(SDECAPTID),0)
QUIT
+45 ;validate CANCELLATION REASON pointer (optional)
+46 SET SDECCR=$GET(SDECCR)
+47 ;832
IF SDECCR'=""
IF '$DATA(^SD(409.2,+SDECCR,0))
SET SDECCR=$ORDER(^SD(409.2,"B",SDECCR,0))
+48 ;validate SDECNOT
+49 ;alb/sat 658 - strip out ^
SET SDECNOT=$TRANSLATE($GET(SDECNOT),"^"," ")
+50 ;
+51 ; Add cancellation comment HASHTAGs from #409.88 to beginning of user note. - 756 wtc 6/8/2020
+52 ;
+53 ; Add hashtags in reverse order of receipt so national appear first. wtc 8/19/2020
IF $GET(SDECCMT)'=""
FOR SDECJ=$LENGTH(SDECCMT,U):-1:1
SET SDECNOT=$PIECE(SDECCMT,U,SDECJ)_"_"_SDECNOT
+54 ; Strip off trailing "_". Happens if not extra note text.
IF $EXTRACT(SDECNOT,$LENGTH(SDECNOT))="_"
SET SDECNOT=$EXTRACT(SDECNOT,1,$LENGTH(SDECNOT)-1)
+55 ;
+56 ;validate cancel date/time
+57 SET SDECDATE=$GET(SDECDATE)
+58 ;
+59 ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
+60 ;
+61 ;I SDECDATE'="" S %DT="T" S X=SDECDATE D ^%DT S SDECDATE=Y I Y=-1 S SDECDATE=""
+62 ; wtc 6/18/18
IF SDECDATE'=""
SET SDECDATE=$$NETTOFM^SDECDATE(SDECDATE,"Y","N")
IF SDECDATE=-1
SET SDECDATE=""
+63 IF $GET(SDECDATE)=""
SET SDECDATE=$$NOW^XLFDT
+64 ;validate user
+65 SET SDUSER=$GET(SDUSER)
+66 IF SDUSER'=""
IF '$DATA(^VA(200,+SDUSER,0))
SET SDUSER=""
+67 IF SDUSER=""
SET SDUSER=DUZ
+68 ;Delete APPOINTMENT entries
+69 SET SDECNOD=^SDEC(409.84,SDECAPTID,0)
+70 SET SDECPATID=$PIECE(SDECNOD,U,5)
+71 SET SDECSTART=$PIECE(SDECNOD,U)
+72 ;
+73 ;Lock SDEC node
+74 ;changed SDECPATID to SDECAPTID to get APPOINTMENT ID instead of PATIENT ID ; pwc *745 7/16/2020
+75 ;BI/SD *5.3*740
LOCK +^SDEC(409.84,SDECAPTID):5
IF '$TEST
DO ADERR(SDECI+1,.SDECY,"Another user is working with this patient's record. Please try again later",+SDECAPTID,0)
QUIT
+76 ;cancel check-in if walk-in
+77 IF $PIECE(SDECNOD,U,13)="y"
Begin DoDot:1
+78 SET SDRET=""
+79 DO CHECKIN^SDEC25(.SDRET,SDECAPTID,"@")
End DoDot:1
+80 ;validate EAS Tracking Number
+81 SET EASTRCKNGNMBR=$TRANSLATE($GET(EASTRCKNGNMBR),"^"," ")
+82 IF $LENGTH(EASTRCKNGNMBR)
SET EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
+83 IF EASTRCKNGNMBR=-1
DO ADERR(SDECI,.SDECY,"SDEC08: Invalid EAS Tracking Number",+$GET(SDECAPTID),0)
QUIT
+84 ;cancel SDEC APPOINTMENT record
+85 ;*745
DO SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,$GET(NEWPID),EASTRCKNGNMBR)
+86 ;
+87 ;RESOURCEID
SET SDECSC1=$PIECE(SDECNOD,U,7)
+88 ;BI/SD*5.3*740 added ADERR ;changed SDECPATID to SDECAPTID - pwc *745
IF SDECSC1]""
IF $DATA(^SDEC(409.831,SDECSC1,0))
Begin DoDot:1
+89 SET SDECNOD=^SDEC(409.831,SDECSC1,0)
+90 ;HOSPITAL LOCATION
SET SDECLOC=$PIECE(SDECNOD,U,4)
+91 if '+SDECLOC
QUIT
+92 ;Q:SDECZ
SET SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART)
IF SDECSCIEN=""
Begin DoDot:2
+93 SET SDECERR="SDEC08: Unable to find associated appointment for this patient. "
+94 SET SDECZ=1
IF '$DATA(^SDEC(409.831,SDECSC1,20))
SET SDECZ=0
QUIT
+95 NEW SDEC1
SET SDEC1=0
+96 FOR
SET SDEC1=$ORDER(^SDEC(409.831,SDECSC1,20,SDEC1))
if '+SDEC1
QUIT
if SDECZ=0
QUIT
Begin DoDot:3
+97 if '$DATA(^SDEC(409.831,SDECSC1,20,SDEC1,0))
QUIT
+98 SET SDECLOC=$PIECE(^SDEC(409.831,SDECSC1,20,SDEC1,0),U)
+99 SET SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART)
IF +SDECSCIEN
SET SDECZ=0
QUIT
End DoDot:3
End DoDot:2
IF 'SDECZ
QUIT
+100 SET SDECERR="SDEC08: CANCEL^SDEC08 Returned "
+101 IF SDECLOC']""
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+102 IF '$DATA(^SC(SDECLOC,0))
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+103 SET SDECNOD=$GET(^SC(SDECLOC,"S",SDECSTART,1,+SDECSCIEN,0))
+104 IF SDECNOD=""
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+105 SET SDECLEN=$PIECE(SDECNOD,U,2)
+106 DO APCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECAPTID,SDECLEN)
+107 if +$GET(SDECZ)
QUIT
+108 ;moved to SDEC08A routine is too big *745
DO AVUPDT^SDEC08A(SDECLOC,SDECSTART,SDECLEN)
+109 DO AR433D^SDECAR2(SDECAPTID)
End DoDot:1
IF +$GET(SDECZ)
SET SDECERR=+SDECZ
DO ADERR(SDECI,.SDECY,$PIECE(SDECZ,U,2),+SDECAPTID,1)
QUIT
+110 ;changed SDECPATID to SDECAPTID ; pwc *745
LOCK -^SDEC(409.84,SDECAPTID)
+111 SET SDECI=SDECI+1
+112 SET @SDECY@(SDECI)=""_$CHAR(30)
+113 SET SDECI=SDECI+1
+114 SET @SDECY@(SDECI)=$CHAR(31)
+115 QUIT
+116 ;
ADERR(SDECI,SDECY,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID ; pwc *745
+1 SET SDECI=SDECI+1
+2 SET SDECERR=$TRANSLATE(SDECERR,"^","~")
+3 SET @SDECY@(SDECI)=SDECERR_$CHAR(30)
+4 SET SDECI=SDECI+1
+5 SET @SDECY@(SDECI)=$CHAR(31)
+6 ; changed SDECPATID to SDECAPTID ; pwc *745
IF LOCK=1
LOCK -^SDEC(409.84,SDECAPTID)
+7 QUIT
+8 ;
SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,NEWPID,EASTRCKNGNMBR) ;cancel SDEC APPOINTMENT entry
+1 ;SDECAPTID - (required) pointer to SDEC APPOINTMENT file
+2 ;SDECTYP - (required) appointment Status valid values:
+3 ; C=CANCELLED BY CLINIC
+4 ; PC=CANCELLED BY PATIENT
+5 ;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
+6 ;SDECNOT - (optional) text representing user note
+7 ;SDECDATE - (optional) Cancel Date/Time in fm format; defaults to NOW) ;
+8 ;SDF - (optional) flags ;*745 expanded flag explanation
+9 ; "1" or null - update consult only. (assumption called from a GUI)
+10 ; "01" (two digit) -do not reopen appt (called from cancel in SDAM)
+11 ; "2" - close appt request disp code REMOVED/EXTERNAL APP
+12 ; "3" - Block & Move don't re-open a Appt Request if a Recall
+13 ;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
+14 ;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
+15 ;
+16 ;Cancel SDEC APPOINTMENT entry
+17 NEW DFN,PROVIEN,Y
+18 ;alb/sat 651 add SAVESTRT and SDRES
NEW SAVESTRT,SDAPTYP,SDCL,SDI,SDIEN,SDECIENS,SDECFDA,SDECMSG,SDECWP,SDRES,SDT
+19 ;**792
NEW DFN40985,IEN40986,PIDCHANGEVERIF,CSFDA,CSSIEN,ERR,CONSIEN,PIDHIEN,SDRESTPOST
+20 SET SDF=$GET(SDF,0)
+21 SET NEWPID=$GET(NEWPID)
+22 ;alb/sat 658;781 lab added, "I"
SET DFN=$$GET1^DIQ(409.84,SDECAPTID_",",.05,"I")
+23 SET SDT=$$GET1^DIQ(409.84,SDECAPTID_",",.01,"I")
+24 ;alb/sat 651
SET SAVESTRT=$$GET1^DIQ(409.84,SDECAPTID_",",.01)
+25 ;alb/sat 651
SET SDRES=$$GET1^DIQ(409.84,SDECAPTID_",",.07,"I")
+26 SET SDECIENS=SDECAPTID_","
+27 SET SDECFDA(409.84,SDECIENS,.12)=$SELECT($GET(SDECDATE)'="":SDECDATE,1:$$NOW^XLFDT)
+28 SET SDECFDA(409.84,SDECIENS,.121)=$SELECT($GET(SDUSER)'="":SDUSER,1:DUZ)
+29 if $GET(SDECCR)'=""
SET SDECFDA(409.84,SDECIENS,.122)=SDECCR
+30 SET SDECFDA(409.84,SDECIENS,.17)=SDECTYP
+31 ;S SDECFDA(409.84,SDECIENS,2)="@" ;patch SD*5.3*796, delete VVS appointment ID if appointment is cancelled
+32 if $GET(EASTRCKNGNMBR)'=""
SET SDECFDA(409.84,SDECIENS,100)=EASTRCKNGNMBR
+33 KILL SDECMSG
+34 DO FILE^DIE("","SDECFDA","SDECMSG")
+35 SET SDAPTYP=$$GET1^DIQ(409.84,SDECAPTID_",",.22,"I")
+36 IF SDF=3
IF $PIECE(SDAPTYP,";",2)'="SD(403.5,"
SET SDF=0
+37 ;alb/sat 658 modification begin
+38 ;,SDECNOT=$E(SDECNOT,1,160) - removed 160 character restriction so entire note is stored in #409.84 - wtc 756
SET SDECNOT=$GET(SDECNOT)
+39 IF $LENGTH(SDECNOT)>2
IF '$EXTRACT(SDF,2)
KILL SDECFDA
+40 ; restrict note in #2 to 160 characters - wtc 756
SET SDECFDA(2.98,SDT_","_DFN_",",17)=$EXTRACT(SDECNOT,1,160)
DO UPDATE^DIE("","SDECFDA")
+41 ; VSE-863; 6/6/2021 ; create new "APPT" Request if A "RECALL" Appt is Cancelled
+42 IF $PIECE(SDAPTYP,";",2)="SD(403.5,"
Begin DoDot:1
+43 if SDF=3
QUIT
+44 DO RECREQ^SDECRECREQ(.SDECY,SDECAPTID,SDAPTYP,$GET(NEWPID),$GET(SDECTYP))
End DoDot:1
QUIT
+45 ;alb/sat 658 modification end
+46 IF $PIECE(SDAPTYP,";",2)="GMR(123,"
IF $EXTRACT(SDF,1)
IF (SDF'=2)
Begin DoDot:1
+47 SET SDCL=$$SDCL^SDECUTL(SDECAPTID)
+48 SET PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
+49 ;651 added SAVESTRT
DO REQSET^SDEC07A($PIECE(SDAPTYP,";",1),PROVIEN,"",2,SDECTYP,SDECNOT,SAVESTRT,SDRES)
+50 IF $GET(NEWPID)
Begin DoDot:2
+51 SET CONSIEN=$PIECE(SDAPTYP,";",1)
+52 SET PIDHIEN=$ORDER(^SDEC(409.87,"B",CONSIEN,0))
+53 SET CSFDA(409.871,"+1,"_PIDHIEN_",",.01)=$$NOW^XLFDT
+54 SET CSFDA(409.871,"+1,"_PIDHIEN_",",1)=$GET(NEWPID)
+55 SET CSFDA(409.871,"+1,"_PIDHIEN_",",2)=$$GET1^DIQ(200,SDUSER,.01,"E")
+56 DO UPDATE^DIE("","CSFDA","CSSIEN","ERR")
KILL CSFDA
End DoDot:2
End DoDot:1
+57 ;
+58 ;update APPT
IF $PIECE(SDAPTYP,";",2)="SDEC(409.85,"
Begin DoDot:1
+59 KILL SDECFDA,SDECMSG,SDECWP
+60 if '$EXTRACT(SDF,2)
DO AROPEN^SDECAR("",SDECAPTID)
+61 SET SDIEN=$PIECE(SDAPTYP,";",1)
+62 SET SDECFDA(409.85,SDIEN_",",13)="@"
+63 SET SDECFDA(409.85,SDIEN_",",13.1)="@"
+64 SET SDECFDA(409.85,SDIEN_",",13.2)="@"
+65 SET SDECFDA(409.85,SDIEN_",",13.3)="@"
+66 SET SDECFDA(409.85,SDIEN_",",13.4)="@"
+67 SET SDECFDA(409.85,SDIEN_",",13.5)="@"
+68 SET SDECFDA(409.85,SDIEN_",",13.6)="@"
+69 SET SDECFDA(409.85,SDIEN_",",13.7)="@"
+70 SET SDECFDA(409.85,SDIEN_",",13.8)="@"
+71 SET PIDCHANGEVERIF=$SELECT(SDECTYP="C":0,SDECTYP="PC":1,1:"")
+72 SET SDECFDA(409.85,SDIEN_",",49)=PIDCHANGEVERIF
+73 if $GET(EASTRCKNGNMBR)'=""
SET SDECFDA(409.85,SDIEN_",",100)=EASTRCKNGNMBR
+74 ; If Canc Don't Re-Open and no existing Disp Code
+75 IF ($$GET1^DIQ(409.2,SDECCR,5,"I")=0)
IF ($$GET1^DIQ(409.85,SDIEN,21,"I")="")
Begin DoDot:2
+76 SET SDECFDA(409.85,SDIEN_",",19)=$PIECE($$GET1^DIQ(409.84,SDECAPTID,.12,"I"),".",1)
+77 SET SDECFDA(409.85,SDIEN_",",20)=$$GET1^DIQ(409.84,SDECAPTID,.121,"I")
+78 SET SDECFDA(409.85,SDIEN_",",21)=$ORDER(^SDEC(409.853,"B","CANCELLED NOT RE-OPENED",""))
End DoDot:2
+79 DO UPDATE^DIE("","SDECFDA","ARRET","ERRMSG")
+80 ;*745
IF SDF=2
NEW INP
SET INP(1)=SDIEN
SET INP(2)="REMOVED/EXTERNAL APP"
SET INP(3)=SDUSER
SET INP(4)=DT
DO ARCLOSE^SDECAR("",.INP)
End DoDot:1
+81 QUIT
+82 ;
CANEVT(SDECPAT,SDECSTART,SDECSC) ;EP Called by SDEC CANCEL APPOINTMENT
+1 ;when Appt cancelled via PIMS interface.
+2 ;Propagates cancel to SDECAPPT & raises refresh event to running GUI clients
+3 NEW SDECFOUND,SDECRES
+4 if +$GET(SDECNOEV)
QUIT
+5 if '+$GET(SDECSC)
QUIT
+6 SET SDECFOUND=0
+7 IF $DATA(^SDEC(409.831,"ALOC",SDECSC))
SET SDECRES=$ORDER(^SDEC(409.831,"ALOC",SDECSC,0))
SET SDECFOUND=$$CANEVT1(SDECRES,SDECSTART,SDECPAT)
+8 IF SDECFOUND
DO CANEVT3(SDECRES)
QUIT
+9 QUIT
+10 ;
CANEVT1(SDECRES,SDECSTART,SDECPAT) ;
+1 ;Get Appt ID in SDECAPT
+2 ;If found, call SDECCAN(SDECAPPT) and return 1
+3 ;else return 0
+4 NEW SDECFOUND,SDECAPPT
+5 SET SDECFOUND=0
+6 if '+SDECRES
QUIT SDECFOUND
+7 if '$DATA(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART))
QUIT SDECFOUND
+8 SET SDECAPPT=0
FOR
SET SDECAPPT=$ORDER(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART,SDECAPPT))
if '+SDECAPPT
QUIT
Begin DoDot:1
+9 SET SDECNOD=$GET(^SDEC(409.84,SDECAPPT,0))
if SDECNOD=""
QUIT
+10 IF $PIECE(SDECNOD,U,5)=SDECPAT
IF $PIECE(SDECNOD,U,12)=""
SET SDECFOUND=1
QUIT
End DoDot:1
if SDECFOUND
QUIT
+11 IF SDECFOUND
IF +$GET(SDECAPPT)
DO SDECCAN(SDECAPPT,,,,,,1)
+12 QUIT SDECFOUND
+13 ;
CANEVT3(SDECRES) ;
+1 ;Call RaiseEvent to notify GUI clients
+2 QUIT
+3 NEW SDECRESN
+4 SET SDECRESN=$GET(^SDEC(409.831,SDECRES,0))
+5 if SDECRESN=""
QUIT
+6 SET SDECRESN=$PIECE(SDECRESN,"^")
+7 QUIT
+8 ;
CANCEL(BSDR) ;EP; called to cancel appt
+1 ; Make call using: S ERR=$$CANCEL^SDEC08(.ARRAY)
+2 ;
+3 ; Input Array -
+4 ; BSDR("PAT") = ien of patient file 2
+5 ; BSDR("CLN") = ien of clinic file 44
+6 ; BSDR("TYP") = C for canceled by clinic; PC for patient canceled
+7 ; BSDR("ADT") = appointment date and time
+8 ; BSDR("CDT") = cancel date and time
+9 ; BSDR("USR") = user who canceled appt
+10 ; BSDR("CR") = cancel reason - pointer to file 409.2
+11 ; BSDR("NOT") = cancel remarks - optional notes to 160 characters
+12 ;
+13 ;Output: error status and message
+14 ; = 0 or null: everything okay
+15 ; = 1^message: error and reason
+16 ;
+17 IF '$DATA(^DPT(+$GET(BSDR("PAT")),0))
QUIT 1_U_"Patient not on file: "_$GET(BSDR("PAT"))
+18 IF '$DATA(^SC(+$GET(BSDR("CLN")),0))
QUIT 1_U_"Clinic not on file: "_$GET(BSDR("CLN"))
+19 IF ($GET(BSDR("TYP"))'="C")
IF ($GET(BSDR("TYP"))'="PC")
QUIT 1_U_"Cancel Status error: "_$GET(BSDR("TYP"))
+20 ;PWC allow any time combination of numbers #694
IF $GET(BSDR("ADT"))'?7N1"."1N.N
QUIT 1_U_"Appt Date/Time error: "_$GET(BSDR("ADT"))
+21 ;PWC allow any time combination of numbers #694
IF $GET(BSDR("CDT"))'?7N1"."1N.N
QUIT 1_U_"Appt Date/Time error: "_$GET(BSDR("ADT"))
+22 IF '$DATA(^VA(200,+$GET(BSDR("USR")),0))
QUIT 1_U_"User Who Canceled Appt Error: "_$GET(BSDR("USR"))
+23 IF '$DATA(^SD(409.2,+$GET(BSDR("CR"))))
QUIT 1_U_"Cancel Reason error: "_$GET(BSDR("CR"))
+24 ;
+25 ;*zeb+1 722 2/21/19 save IEN for canceling appt
NEW IEN,DIE,DA,DR,SDMODE,HLAPTIEN
+26 SET IEN=$$SCIEN^SDECU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
SET HLAPTIEN=IEN
+27 IF 'IEN
QUIT 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
+28 ;
+29 IF $$CI^SDECU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN)
QUIT 1_U_"Patient already checked in; cannot cancel until check-in deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
+30 ;
+31 ; remember before status
+32 NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
+33 SET DFN=BSDR("PAT")
SET SDT=BSDR("ADT")
SET SDCL=BSDR("CLN")
SET SDMODE=2
SET SDDA=IEN
+34 SET SDCPHDL=$$HANDLE^SDAMEVT(1)
SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+35 DO BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
+36 ;
+37 ; get user who made appt and date appt made from ^SC
+38 ; because data in ^SC will be deleted
+39 NEW USER,DATE
+40 SET USER=$PIECE($GET(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
+41 SET DATE=$PIECE($GET(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
+42 ;
+43 ; update file 2 info
+44 NEW DIE,DA,DR
+45 NEW SDFDA,SDIEN,SDMSG
+46 SET SDFDA="SDFDA(2.98,SDT_"",""_DFN_"","")"
+47 SET @SDFDA@(3)=BSDR("TYP")
+48 SET @SDFDA@(14)=BSDR("USR")
+49 SET @SDFDA@(15)=BSDR("CDT")
+50 if +$GET(BSDR("CR"))
SET @SDFDA@(16)=BSDR("CR")
+51 if $GET(BSDR("NOT"))]""
SET @SDFDA@(17)=$EXTRACT(BSDR("NOT"),1,160)
+52 SET @SDFDA@(19)=USER
+53 SET @SDFDA@(20)=DATE
+54 ; ICR #7030 wtc 756 6/15/2020
DO UPDATE^DIE("","SDFDA")
+55 NEW SDPCE
+56 ; ICR #7030 wtc 756 6/15/2020
SET SDPCE=$PIECE($GET(^DPT(DFN,"S",SDT,0)),U,20)
+57 ;remove OUTPATIENT ENCOUNTER link ;*zeb 10/25/18 722 pass in correct SDMODE and delete source
if +SDPCE
DO EN^SDCODEL(SDPCE,2,"","CANCEL")
+58 SET $PIECE(^SC(BSDR("CLN"),"S",BSDR("ADT"),1,HLAPTIEN,0),"^",9)="C"
+59 ; call event driver
+60 SET SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+61 ;*zeb 10/25/18 722 uncomment to re-enable event driver
DO CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
+62 QUIT 0
+63 ;
UNDOCANA(SDECY,SDECAPTID) ;Undo Cancel Appointment
+1 ;UNDOCANA(SDECY,SDECAPTID) external parameter tag in SDEC
+2 ;called by SDEC UNCANCEL APPT
+3 ; SDECAPTID = ien of appointment in SDEC APPOINTMENT (^SDECAPPT) file 409.84
+4 NEW SDECDAM,SDECDEC,SDECI,SDECNOD,SDECPATID,SDECSTART,SDECNOTE,SDECWKIN
+5 ;Don't execute SDEC CANCEL APPOINTMENT protocol ;is this used?
SET SDECNOEV=1
+6 ;
+7 SET SDECI=0
+8 KILL ^TMP("SDEC",$JOB)
+9 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+10 SET ^TMP("SDEC",$JOB,SDECI)="T00020ERRORID"_$CHAR(30)
+11 ;BI/SD*5.3*740
IF '+SDECAPTID
DO ERR(SDECI+1,"Invalid Appointment ID.",+$GET(SDECAPTID),0)
QUIT
+12 ;BI/SD*5.3*740
IF '$DATA(^SDEC(409.84,SDECAPTID,0))
DO ERR(SDECI+1,"Invalid Appointment ID",+SDECAPTID,0)
QUIT
+13 ;Make sure appointment is cancelled
+14 ;BI/SD*5.3*740
IF $$GET1^DIQ(409.84,SDECAPTID_",",.12)=""
DO ERR(SDECI+1,"Appointment is not Cancelled.",+SDECAPTID,0)
QUIT
+15 SET SDECNOD=^SDEC(409.84,SDECAPTID,0)
+16 ;appts cancelled by patient cannot be un-cancelled. /* removed 9/17/2010 */
+17 ;I $P(^DPT($P(SDECNOD,U,5),"S",$P(SDECNOD,U,1),0),U,2)="PC" TROLLBACK D ERR(SDECI+1,"Cancelled by patient appointment cannot be uncancelled.") Q
+18 ;get appointment data
+19 SET SDECNOD=^SDEC(409.84,SDECAPTID,0)
+20 ;date appt made
SET SDECDAM=$PIECE(SDECNOD,U,9)
+21 ;data entry clerk
SET SDECDEC=$PIECE(SDECNOD,U,8)
+22 ;length of appt in minutes
SET SDECLEN=$PIECE(SDECNOD,U,18)
+23 ;
+24 ; Get entire note from Appointment file. 756 wtc 1/25/2019
+25 ;
+26 ;S SDECNOTE=$G(^SDEC(409.84,SDECAPTID,1,1,0)) ;note from SDEC APPOINTMENT
+27 ;
SET SDECNOTE=""
NEW I
FOR I=1:1
if '$DATA(^SDEC(409.84,SDECAPTID,1,I,0))
QUIT
SET SDECNOTE=SDECNOTE_^(0)_$CHAR(13)
+28 ;
+29 ;pointer to VA PATIENT file 2
SET SDECPATID=$PIECE(SDECNOD,U,5)
+30 ;resource
SET SDECSC1=$PIECE($GET(SDECNOD),U,7)
+31 ;appt start time
SET SDECSTART=$PIECE(SDECNOD,U)
+32 ;walk-in
SET SDECWKIN=$PIECE($GET(SDECNOD),U,13)
+33 ;lock SDEC node
+34 ; changed line below to use SDECAPTID instead of SDECPATID ; pwc *745 7/16/2020
+35 ;BI/SD*5.3*740
LOCK +^SDEC(409.84,SDECAPTID):5
IF '$TEST
DO ERR(SDECI+1,"Another user is working with this patient's record. Please try again later",+SDECAPTID,0)
QUIT
+36 ;un-cancel SDEC APPOINTMENT
+37 ;moved to ^SDEC08A because of XINDEX size *756 PWC
DO SDECUCAN^SDEC08A(SDECAPTID)
+38 ;BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID - pwc *745
IF SDECSC1]""
IF $DATA(^SDEC(409.831,SDECSC1,0))
Begin DoDot:1
+39 SET SDECLOC=""
+40 SET SDECNOD=^SDEC(409.831,SDECSC1,0)
+41 ;HOSPITAL LOCATION ;support for single HOSPITAL LOCATION in SDEC RESOURCE
SET SDECLOC=$PIECE(SDECNOD,U,4)
+42 ;HOSPITAL LOCATION
IF SDECLOC=""
SET SDECLOC=$$SDCL^SDECUTL(SDECAPTID)
+43 if '+SDECLOC
QUIT
+44 ;un-cancel patient appointment and re-instate clinic appointment
+45 SET SDECZ=""
+46 ;moved to ^SDEC08A because of XINDEX size *756 PWC
DO APUCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECDAM,SDECDEC,SDECLEN,SDECNOTE,SDECSC1,SDECWKIN)
End DoDot:1
IF +$GET(SDECZ)
SET SDECERR=SDECERR_$PIECE(SDECZ,U,2)
DO ERR(SDECI,SDECERR,+SDECAPTID,1)
QUIT
+47 ;changed SDECPATID to SDECAPTID - pwc *745
LOCK -^SDEC(409.84,SDECAPTID)
+48 SET SDECI=SDECI+1
+49 SET ^TMP("SDEC",$JOB,SDECI)=""_$CHAR(30)
+50 SET SDECI=SDECI+1
+51 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+52 QUIT
+53 ;
ERR(SDECI,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 added two parameters ;changed SDECPATID to SDECAPTID - pwc *745
+1 SET SDECI=SDECI+1
+2 SET SDECERR=$TRANSLATE(SDECERR,"^","~")
+3 SET ^TMP("SDEC",$JOB,SDECI)=SDECERR_$CHAR(30)
+4 SET SDECI=SDECI+1
+5 SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+6 ;BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID - pwc *745
IF $GET(LOCK)=1
LOCK -^SDEC(409.84,SDECAPTID)
+7 QUIT
+8 ;
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 IF '$DATA(SDECI)
NEW SDECI
SET SDECI=999999
+3 SET SDECI=SDECI+1
+4 DO ERR(SDECI,"SDEC08 Error")
+5 QUIT
