EHMSDEC8 ;ALB/SAT/JSM,WTC,LAB,LEG,RRM,MGD - DELETE APPTS ; Jun 05, 2025@14:53:21
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
;
; Cloned from SDEC08 then modified.
;
Q ;
;
APPDEL(SDECAPTID,SDECTYP,SDECCR) ;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
; CNV=Converted to Cerner
;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
;
;Returns 1 if successful or 0^error reason
;
N SDECNOD,SDECPATID,SDECSTART,DIK,DA,SDECID,SDECZ,SDECERR
N SDECLOC,SDECLEN,SDECSCIEN,SDECSCIEN1,SDECNOEV,SDECSC1,SDRET
N %DT,X,Y,SDECJ,SDECNOT ; wtc 756 6/8/2020 added SDECJ
S SDECSCIEN1=0
;
;validate SDEC APPOINTMENT pointer (required)
I '$D(^SDEC(409.84,+$G(SDECAPTID),0)) Q "0^Invalid file pointer" ;D ADERR(SDECI,.SDECY,"SDEC08: Invalid Appointment ID",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740 added ADERR
;validate appointment status type (required)
S SDECTYP=$G(SDECTYP) I SDECTYP'="CNV",SDECTYP'="C" Q "0^Invalid appointment status ("_SDECTYP_")" ;
;validate CANCELLATION REASON pointer (optional)
S SDECCR=$G(SDECCR) I SDECCR="" Q "0^Cancellation Reason missing" ;
I '$D(^SD(409.2,+SDECCR,0)) S SDECCR=$O(^SD(409.2,"B",SDECCR,0)) ;832
;
S SDECDATE=$$NOW^XLFDT
S SDUSER=DUZ
;Delete APPOINTMENT entries
S SDECNOD=^SDEC(409.84,SDECAPTID,0)
S SDECPATID=$P(SDECNOD,U,5)
S SDECSTART=$P(SDECNOD,U)
;
;cancel check-in if walk-in
I $P(SDECNOD,U,13)="y" D
.S SDRET=""
.D CHECKIN^SDEC25(.SDRET,SDECAPTID,"@")
;cancel SDEC APPOINTMENT record
N SDF S SDF=1 ; WTC 8.29.23
D SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECDATE,SDUSER) ;
;
S SDECSC1=$P(SDECNOD,U,7) ;RESOURCEID
I SDECSC1]"",$D(^SDEC(409.831,SDECSC1,0)) D I +$G(SDECZ) Q "0^Resource error" ;
. S SDECNOD=$G(^SDEC(409.831,SDECSC1,0)) ; WTC 6/18/24 BAD DATA
. S SDECLOC=$P(SDECNOD,U,4) ;HOSPITAL LOCATION
. Q:'+SDECLOC
. S SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART) I SDECSCIEN="" D I 'SDECZ Q ;
.. 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)
. ;
. S SDECNOT="" ; WTC 8.28.23
. D APCAN^EHMSDC8A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECAPTID,SDECLEN)
. Q:+$G(SDECZ)
. D AVUPDT^EHMSDC8A(SDECLOC,SDECSTART,SDECLEN) ;
. D AR433D^SDECAR2(SDECAPTID)
Q 1 ;
;
SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECDATE,SDUSER) ;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)
;
;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 ;**792
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
K SDECMSG
D FILE^DIE("","SDECFDA","SDECMSG")
S SDAPTYP=$$GET1^DIQ(409.84,SDECAPTID_",",.22,"I")
;alb/sat 658 modification begin
D UPDATE^DIE("","SDECFDA") ; restrict note in #2 to 160 characters - wtc 756
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)="@"
.; 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",""))
..S SDECFDA(409.85,SDIEN_",",23)="C" ; Mark request closed. wtc 8.29.23
.D UPDATE^DIE("","SDECFDA","ARRET","ERRMSG")
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"),($G(BSDR("TYP"))'="CNV") Q 1_U_"Cancel Status error: "_$G(BSDR("TYP")) ; WTC 8.29.23
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
; DISABLED WTC 2/28/24 ;S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
; DISABLED WTC 2/28/24 ;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
; DISABLED WTC 2/28/24 ;I SDPCE D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL) ; WTC 2/14/24 Do not call protocol if encounter is not present.
Q 0
;
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[HEHMSDEC8 9420 printed Apr 22, 2026@13:48:27 Page 2
EHMSDEC8 ;ALB/SAT/JSM,WTC,LAB,LEG,RRM,MGD - DELETE APPTS ; Jun 05, 2025@14:53:21
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**13**;Apr 19, 2021;Build 27
+2 ;
+3 ; Cloned from SDEC08 then modified.
+4 ;
+5 ;
QUIT
+6 ;
APPDEL(SDECAPTID,SDECTYP,SDECCR) ;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 ; CNV=Converted to Cerner
+6 ;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
+7 ;
+8 ;Returns 1 if successful or 0^error reason
+9 ;
+10 NEW SDECNOD,SDECPATID,SDECSTART,DIK,DA,SDECID,SDECZ,SDECERR
+11 NEW SDECLOC,SDECLEN,SDECSCIEN,SDECSCIEN1,SDECNOEV,SDECSC1,SDRET
+12 ; wtc 756 6/8/2020 added SDECJ
NEW %DT,X,Y,SDECJ,SDECNOT
+13 SET SDECSCIEN1=0
+14 ;
+15 ;validate SDEC APPOINTMENT pointer (required)
+16 ;D ADERR(SDECI,.SDECY,"SDEC08: Invalid Appointment ID",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740 added ADERR
IF '$DATA(^SDEC(409.84,+$GET(SDECAPTID),0))
QUIT "0^Invalid file pointer"
+17 ;validate appointment status type (required)
+18 ;
SET SDECTYP=$GET(SDECTYP)
IF SDECTYP'="CNV"
IF SDECTYP'="C"
QUIT "0^Invalid appointment status ("_SDECTYP_")"
+19 ;validate CANCELLATION REASON pointer (optional)
+20 ;
SET SDECCR=$GET(SDECCR)
IF SDECCR=""
QUIT "0^Cancellation Reason missing"
+21 ;832
IF '$DATA(^SD(409.2,+SDECCR,0))
SET SDECCR=$ORDER(^SD(409.2,"B",SDECCR,0))
+22 ;
+23 SET SDECDATE=$$NOW^XLFDT
+24 SET SDUSER=DUZ
+25 ;Delete APPOINTMENT entries
+26 SET SDECNOD=^SDEC(409.84,SDECAPTID,0)
+27 SET SDECPATID=$PIECE(SDECNOD,U,5)
+28 SET SDECSTART=$PIECE(SDECNOD,U)
+29 ;
+30 ;cancel check-in if walk-in
+31 IF $PIECE(SDECNOD,U,13)="y"
Begin DoDot:1
+32 SET SDRET=""
+33 DO CHECKIN^SDEC25(.SDRET,SDECAPTID,"@")
End DoDot:1
+34 ;cancel SDEC APPOINTMENT record
+35 ; WTC 8.29.23
NEW SDF
SET SDF=1
+36 ;
DO SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECDATE,SDUSER)
+37 ;
+38 ;RESOURCEID
SET SDECSC1=$PIECE(SDECNOD,U,7)
+39 ;
IF SDECSC1]""
IF $DATA(^SDEC(409.831,SDECSC1,0))
Begin DoDot:1
+40 ; WTC 6/18/24 BAD DATA
SET SDECNOD=$GET(^SDEC(409.831,SDECSC1,0))
+41 ;HOSPITAL LOCATION
SET SDECLOC=$PIECE(SDECNOD,U,4)
+42 if '+SDECLOC
QUIT
+43 ;
SET SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART)
IF SDECSCIEN=""
Begin DoDot:2
+44 SET SDECERR="SDEC08: Unable to find associated appointment for this patient. "
+45 SET SDECZ=1
IF '$DATA(^SDEC(409.831,SDECSC1,20))
SET SDECZ=0
QUIT
+46 NEW SDEC1
SET SDEC1=0
+47 FOR
SET SDEC1=$ORDER(^SDEC(409.831,SDECSC1,20,SDEC1))
if '+SDEC1
QUIT
if SDECZ=0
QUIT
Begin DoDot:3
+48 if '$DATA(^SDEC(409.831,SDECSC1,20,SDEC1,0))
QUIT
+49 SET SDECLOC=$PIECE(^SDEC(409.831,SDECSC1,20,SDEC1,0),U)
+50 SET SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART)
IF +SDECSCIEN
SET SDECZ=0
QUIT
End DoDot:3
End DoDot:2
IF 'SDECZ
QUIT
+51 SET SDECERR="SDEC08: CANCEL^SDEC08 Returned "
+52 IF SDECLOC']""
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+53 IF '$DATA(^SC(SDECLOC,0))
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+54 SET SDECNOD=$GET(^SC(SDECLOC,"S",SDECSTART,1,+SDECSCIEN,0))
+55 IF SDECNOD=""
SET SDECZ="0^Unable to find associated appointment for this patient."
QUIT
+56 SET SDECLEN=$PIECE(SDECNOD,U,2)
+57 ;
+58 ; WTC 8.28.23
SET SDECNOT=""
+59 DO APCAN^EHMSDC8A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECAPTID,SDECLEN)
+60 if +$GET(SDECZ)
QUIT
+61 ;
DO AVUPDT^EHMSDC8A(SDECLOC,SDECSTART,SDECLEN)
+62 DO AR433D^SDECAR2(SDECAPTID)
End DoDot:1
IF +$GET(SDECZ)
QUIT "0^Resource error"
+63 ;
QUIT 1
+64 ;
SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECDATE,SDUSER) ;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 ;
+7 ;Cancel SDEC APPOINTMENT entry
+8 NEW DFN,PROVIEN,Y
+9 ;alb/sat 651 add SAVESTRT and SDRES
NEW SAVESTRT,SDAPTYP,SDCL,SDI,SDIEN,SDECIENS,SDECFDA,SDECMSG,SDECWP,SDRES,SDT
+10 ;**792
NEW DFN40985,IEN40986,PIDCHANGEVERIF,CSFDA,CSSIEN,ERR,CONSIEN,PIDHIEN
+11 ;alb/sat 658;781 lab added, "I"
SET DFN=$$GET1^DIQ(409.84,SDECAPTID_",",.05,"I")
+12 SET SDT=$$GET1^DIQ(409.84,SDECAPTID_",",.01,"I")
+13 ;alb/sat 651
SET SAVESTRT=$$GET1^DIQ(409.84,SDECAPTID_",",.01)
+14 ;alb/sat 651
SET SDRES=$$GET1^DIQ(409.84,SDECAPTID_",",.07,"I")
+15 SET SDECIENS=SDECAPTID_","
+16 SET SDECFDA(409.84,SDECIENS,.12)=$SELECT($GET(SDECDATE)'="":SDECDATE,1:$$NOW^XLFDT)
+17 SET SDECFDA(409.84,SDECIENS,.121)=$SELECT($GET(SDUSER)'="":SDUSER,1:DUZ)
+18 if $GET(SDECCR)'=""
SET SDECFDA(409.84,SDECIENS,.122)=SDECCR
+19 SET SDECFDA(409.84,SDECIENS,.17)=SDECTYP
+20 KILL SDECMSG
+21 DO FILE^DIE("","SDECFDA","SDECMSG")
+22 SET SDAPTYP=$$GET1^DIQ(409.84,SDECAPTID_",",.22,"I")
+23 ;alb/sat 658 modification begin
+24 ; restrict note in #2 to 160 characters - wtc 756
DO UPDATE^DIE("","SDECFDA")
+25 ;update APPT
IF $PIECE(SDAPTYP,";",2)="SDEC(409.85,"
Begin DoDot:1
+26 KILL SDECFDA,SDECMSG,SDECWP
+27 if '$EXTRACT(SDF,2)
DO AROPEN^SDECAR("",SDECAPTID)
+28 SET SDIEN=$PIECE(SDAPTYP,";",1)
+29 SET SDECFDA(409.85,SDIEN_",",13)="@"
+30 SET SDECFDA(409.85,SDIEN_",",13.1)="@"
+31 SET SDECFDA(409.85,SDIEN_",",13.2)="@"
+32 SET SDECFDA(409.85,SDIEN_",",13.3)="@"
+33 SET SDECFDA(409.85,SDIEN_",",13.4)="@"
+34 SET SDECFDA(409.85,SDIEN_",",13.5)="@"
+35 SET SDECFDA(409.85,SDIEN_",",13.6)="@"
+36 SET SDECFDA(409.85,SDIEN_",",13.7)="@"
+37 SET SDECFDA(409.85,SDIEN_",",13.8)="@"
+38 ; If Canc Don't Re-Open and no existing Disp Code
+39 IF ($$GET1^DIQ(409.2,SDECCR,5,"I")=0)
IF ($$GET1^DIQ(409.85,SDIEN,21,"I")="")
Begin DoDot:2
+40 SET SDECFDA(409.85,SDIEN_",",19)=$PIECE($$GET1^DIQ(409.84,SDECAPTID,.12,"I"),".",1)
+41 SET SDECFDA(409.85,SDIEN_",",20)=$$GET1^DIQ(409.84,SDECAPTID,.121,"I")
+42 SET SDECFDA(409.85,SDIEN_",",21)=$ORDER(^SDEC(409.853,"B","CANCELLED NOT RE-OPENED",""))
+43 ; Mark request closed. wtc 8.29.23
SET SDECFDA(409.85,SDIEN_",",23)="C"
End DoDot:2
+44 DO UPDATE^DIE("","SDECFDA","ARRET","ERRMSG")
End DoDot:1
+45 QUIT
+46 ;
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 ; WTC 8.29.23
IF ($GET(BSDR("TYP"))'="C")
IF ($GET(BSDR("TYP"))'="PC")
IF ($GET(BSDR("TYP"))'="CNV")
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 ; DISABLED WTC 2/28/24 ;S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
+35 ; DISABLED WTC 2/28/24 ;D 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 ; DISABLED WTC 2/28/24 ;I SDPCE D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL) ; WTC 2/14/24 Do not call protocol if encounter is not present.
+62 QUIT 0
+63 ;
ERR(SDECI,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 added two parameters ;changed SDECPATID to SDECAPTID - pwc *745
+1 ;S SDECI=SDECI+1
+2 SET SDECERR=$TRANSLATE(SDECERR,"^","~")
+3 ;S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
+4 ;S SDECI=SDECI+1
+5 ;S ^TMP("SDEC",$J,SDECI)=$C(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 ;I '$D(SDECI) N SDECI S SDECI=999999
+3 ;S SDECI=SDECI+1
+4 ;D ERR(SDECI,"SDEC08 Error")
+5 QUIT
+6 ;
