Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC08

SDEC08.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. ; Reference to ^DPT (Patient File) is supported by IA #7030
  1. Q
  1. ;
  1. 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
  1. ;SDECTYP - (required) appointment Status valid values:
  1. ; C=CANCELLED BY CLINIC
  1. ; PC=CANCELLED BY PATIENT
  1. ;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
  1. ;SDECNOT - (optional) text representing user note
  1. ;SDECDATE - (optional) Cancel Date/Time in external format; defaults to NOW
  1. ;SDUSER - (optional) User that cancelled appt; defaults to current user
  1. ;SOURCE - future enhancement L 1.8 SD*5.3*715
  1. ;SDF - (optional) Flag to determine whether to reopen appointment SD*5.3*745
  1. ;SDECCMT - (optional) List of cancellation comment hash tags (see #409.88) separated by ^ - 756 6/8/2020 wtc
  1. ;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
  1. ;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
  1. ;Returns error code in record set field ERRORID
  1. ;
  1. N SDECNOD,SDECPATID,SDECSTART,DIK,DA,SDECID,SDECI,SDECZ,SDECERR
  1. N SDECLOC,SDECLEN,SDECSCIEN,SDECSCIEN1,SDECNOEV,SDECSC1,SDRET
  1. N %DT,X,Y,SDECJ ; wtc 756 6/8/2020 added SDECJ
  1. S NEWPID=$G(NEWPID)
  1. I $G(NEWPID)'="" D
  1. .S NEWPID=$$NETTOFM^SDECDATE(NEWPID,"N","N")
  1. 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.
  1. S SDECNOEV=1 ;Don't execute SDEC CANCEL APPOINTMENT protocol
  1. S SDECSCIEN1=0
  1. ;
  1. S SDECI=0
  1. S SDECY="^TMP(""SDEC08"","_$J_",""APPDEL"")"
  1. K @SDECY
  1. S @SDECY@(SDECI)="T00020ERRORID"_$C(30)
  1. S SDECI=SDECI+1
  1. ;validate SDEC APPOINTMENT pointer (required)
  1. 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
  1. ;verify unique PID for MRTCs
  1. I NEWPID N DUPERR D Q:$G(DUPERR)
  1. . S DUPERR=0
  1. . N APPTREQTYPE,REQUESTIEN
  1. . S APPTREQTYPE=$$GET1^DIQ(409.84,+$G(SDECAPTID),.22,"I")
  1. . S REQUESTIEN=$P($G(APPTREQTYPE),";")
  1. . I $$DUPPIDCHK^SDES2CANCELAPPT(REQUESTIEN,NEWPID) D
  1. . . S DUPERR=1 D ADERR(SDECI,.SDECY,"SDEC08: PID date already used on another associated child record",+$G(SDECAPTID),0)
  1. ;validate appointment status type (required)
  1. S SDECTYP=$G(SDECTYP)
  1. S SDECTYP=$S(SDECTYP="C":"C",SDECTYP="CANCELLED BY CLINIC":"C",SDECTYP="PC":"PC",SDECTYP="CANCELLED BY PATIENT":"PC",1:"")
  1. I SDECTYP="" D ADERR(SDECI,.SDECY,"SDEC08: Invalid status type",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740 added ADERR
  1. ;validate CANCELLATION REASON pointer (optional)
  1. S SDECCR=$G(SDECCR)
  1. I SDECCR'="" I '$D(^SD(409.2,+SDECCR,0)) S SDECCR=$O(^SD(409.2,"B",SDECCR,0)) ;832
  1. ;validate SDECNOT
  1. S SDECNOT=$TR($G(SDECNOT),"^"," ") ;alb/sat 658 - strip out ^
  1. ;
  1. ; Add cancellation comment HASHTAGs from #409.88 to beginning of user note. - 756 wtc 6/8/2020
  1. ;
  1. 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
  1. I $E(SDECNOT,$L(SDECNOT))="_" S SDECNOT=$E(SDECNOT,1,$L(SDECNOT)-1) ; Strip off trailing "_". Happens if not extra note text.
  1. ;
  1. ;validate cancel date/time
  1. S SDECDATE=$G(SDECDATE)
  1. ;
  1. ; Change date/time conversion so midnight is handled properly. wtc 694 4/24/18
  1. ;
  1. ;I SDECDATE'="" S %DT="T" S X=SDECDATE D ^%DT S SDECDATE=Y I Y=-1 S SDECDATE=""
  1. I SDECDATE'="" S SDECDATE=$$NETTOFM^SDECDATE(SDECDATE,"Y","N") I SDECDATE=-1 S SDECDATE="" ; wtc 6/18/18
  1. I $G(SDECDATE)="" S SDECDATE=$$NOW^XLFDT
  1. ;validate user
  1. S SDUSER=$G(SDUSER)
  1. I SDUSER'="" I '$D(^VA(200,+SDUSER,0)) S SDUSER=""
  1. I SDUSER="" S SDUSER=DUZ
  1. ;Delete APPOINTMENT entries
  1. S SDECNOD=^SDEC(409.84,SDECAPTID,0)
  1. S SDECPATID=$P(SDECNOD,U,5)
  1. S SDECSTART=$P(SDECNOD,U)
  1. ;
  1. ;Lock SDEC node
  1. ;changed SDECPATID to SDECAPTID to get APPOINTMENT ID instead of PATIENT ID ; pwc *745 7/16/2020
  1. 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
  1. ;cancel check-in if walk-in
  1. I $P(SDECNOD,U,13)="y" D
  1. .S SDRET=""
  1. .D CHECKIN^SDEC25(.SDRET,SDECAPTID,"@")
  1. ;validate EAS Tracking Number
  1. S EASTRCKNGNMBR=$TR($G(EASTRCKNGNMBR),"^"," ")
  1. I $L(EASTRCKNGNMBR) S EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
  1. I EASTRCKNGNMBR=-1 D ADERR(SDECI,.SDECY,"SDEC08: Invalid EAS Tracking Number",+$G(SDECAPTID),0) Q
  1. ;cancel SDEC APPOINTMENT record
  1. D SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,$G(NEWPID),EASTRCKNGNMBR) ;*745
  1. ;
  1. S SDECSC1=$P(SDECNOD,U,7) ;RESOURCEID
  1. 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
  1. . S SDECNOD=^SDEC(409.831,SDECSC1,0)
  1. . S SDECLOC=$P(SDECNOD,U,4) ;HOSPITAL LOCATION
  1. . Q:'+SDECLOC
  1. . S SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART) I SDECSCIEN="" D I 'SDECZ Q ;Q:SDECZ
  1. .. S SDECERR="SDEC08: Unable to find associated appointment for this patient. "
  1. .. S SDECZ=1 I '$D(^SDEC(409.831,SDECSC1,20)) S SDECZ=0 Q
  1. .. N SDEC1 S SDEC1=0
  1. .. F S SDEC1=$O(^SDEC(409.831,SDECSC1,20,SDEC1)) Q:'+SDEC1 Q:SDECZ=0 D
  1. ... Q:'$D(^SDEC(409.831,SDECSC1,20,SDEC1,0))
  1. ... S SDECLOC=$P(^SDEC(409.831,SDECSC1,20,SDEC1,0),U)
  1. ... S SDECSCIEN=$$SCIEN^SDECU2(SDECPATID,SDECLOC,SDECSTART) I +SDECSCIEN S SDECZ=0 Q
  1. . S SDECERR="SDEC08: CANCEL^SDEC08 Returned "
  1. . I SDECLOC']"" S SDECZ="0^Unable to find associated appointment for this patient." Q
  1. . I '$D(^SC(SDECLOC,0)) S SDECZ="0^Unable to find associated appointment for this patient." Q
  1. . S SDECNOD=$G(^SC(SDECLOC,"S",SDECSTART,1,+SDECSCIEN,0))
  1. . I SDECNOD="" S SDECZ="0^Unable to find associated appointment for this patient." Q
  1. . S SDECLEN=$P(SDECNOD,U,2)
  1. . D APCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECAPTID,SDECLEN)
  1. . Q:+$G(SDECZ)
  1. . D AVUPDT^SDEC08A(SDECLOC,SDECSTART,SDECLEN) ;moved to SDEC08A routine is too big *745
  1. . D AR433D^SDECAR2(SDECAPTID)
  1. L -^SDEC(409.84,SDECAPTID) ;changed SDECPATID to SDECAPTID ; pwc *745
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=""_$C(30)
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=$C(31)
  1. Q
  1. ;
  1. ADERR(SDECI,SDECY,SDECERR,SDECAPTID,LOCK) ;Error processing BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID ; pwc *745
  1. S SDECI=SDECI+1
  1. S SDECERR=$TR(SDECERR,"^","~")
  1. S @SDECY@(SDECI)=SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S @SDECY@(SDECI)=$C(31)
  1. I LOCK=1 L -^SDEC(409.84,SDECAPTID) ; changed SDECPATID to SDECAPTID ; pwc *745
  1. Q
  1. ;
  1. SDECCAN(SDECAPTID,SDECTYP,SDECCR,SDECNOT,SDECDATE,SDUSER,SDF,NEWPID,EASTRCKNGNMBR) ;cancel SDEC APPOINTMENT entry
  1. ;SDECAPTID - (required) pointer to SDEC APPOINTMENT file
  1. ;SDECTYP - (required) appointment Status valid values:
  1. ; C=CANCELLED BY CLINIC
  1. ; PC=CANCELLED BY PATIENT
  1. ;SDECCR - (required) pointer to CANCELLATION REASON File (409.2)
  1. ;SDECNOT - (optional) text representing user note
  1. ;SDECDATE - (optional) Cancel Date/Time in fm format; defaults to NOW) ;
  1. ;SDF - (optional) flags ;*745 expanded flag explanation
  1. ; "1" or null - update consult only. (assumption called from a GUI)
  1. ; "01" (two digit) -do not reopen appt (called from cancel in SDAM)
  1. ; "2" - close appt request disp code REMOVED/EXTERNAL APP
  1. ; "3" - Block & Move don't re-open a Appt Request if a Recall
  1. ;NEWPID - (optional) Only allowed when cancelling a recall request appointment by patient
  1. ;EASTRCKINGNMBR - (optional) Enterprise Appointment Scheduling Tracking Number associated to an appointment.
  1. ;
  1. ;Cancel SDEC APPOINTMENT entry
  1. N DFN,PROVIEN,Y
  1. N SAVESTRT,SDAPTYP,SDCL,SDI,SDIEN,SDECIENS,SDECFDA,SDECMSG,SDECWP,SDRES,SDT ;alb/sat 651 add SAVESTRT and SDRES
  1. N DFN40985,IEN40986,PIDCHANGEVERIF,CSFDA,CSSIEN,ERR,CONSIEN,PIDHIEN,SDRESTPOST ;**792
  1. S SDF=$G(SDF,0)
  1. S NEWPID=$G(NEWPID)
  1. S DFN=$$GET1^DIQ(409.84,SDECAPTID_",",.05,"I") ;alb/sat 658;781 lab added, "I"
  1. S SDT=$$GET1^DIQ(409.84,SDECAPTID_",",.01,"I")
  1. S SAVESTRT=$$GET1^DIQ(409.84,SDECAPTID_",",.01) ;alb/sat 651
  1. S SDRES=$$GET1^DIQ(409.84,SDECAPTID_",",.07,"I") ;alb/sat 651
  1. S SDECIENS=SDECAPTID_","
  1. S SDECFDA(409.84,SDECIENS,.12)=$S($G(SDECDATE)'="":SDECDATE,1:$$NOW^XLFDT)
  1. S SDECFDA(409.84,SDECIENS,.121)=$S($G(SDUSER)'="":SDUSER,1:DUZ)
  1. S:$G(SDECCR)'="" SDECFDA(409.84,SDECIENS,.122)=SDECCR
  1. S SDECFDA(409.84,SDECIENS,.17)=SDECTYP
  1. ;S SDECFDA(409.84,SDECIENS,2)="@" ;patch SD*5.3*796, delete VVS appointment ID if appointment is cancelled
  1. S:$G(EASTRCKNGNMBR)'="" SDECFDA(409.84,SDECIENS,100)=EASTRCKNGNMBR
  1. K SDECMSG
  1. D FILE^DIE("","SDECFDA","SDECMSG")
  1. S SDAPTYP=$$GET1^DIQ(409.84,SDECAPTID_",",.22,"I")
  1. I SDF=3,$P(SDAPTYP,";",2)'="SD(403.5," S SDF=0
  1. ;alb/sat 658 modification begin
  1. S SDECNOT=$G(SDECNOT) ;,SDECNOT=$E(SDECNOT,1,160) - removed 160 character restriction so entire note is stored in #409.84 - wtc 756
  1. I $L(SDECNOT)>2,'$E(SDF,2) K SDECFDA
  1. S SDECFDA(2.98,SDT_","_DFN_",",17)=$E(SDECNOT,1,160) D UPDATE^DIE("","SDECFDA") ; restrict note in #2 to 160 characters - wtc 756
  1. ; VSE-863; 6/6/2021 ; create new "APPT" Request if A "RECALL" Appt is Cancelled
  1. I $P(SDAPTYP,";",2)="SD(403.5," D Q
  1. .Q:SDF=3
  1. .D RECREQ^SDECRECREQ(.SDECY,SDECAPTID,SDAPTYP,$G(NEWPID),$G(SDECTYP))
  1. ;alb/sat 658 modification end
  1. I $P(SDAPTYP,";",2)="GMR(123,",$E(SDF,1),(SDF'=2) D
  1. .S SDCL=$$SDCL^SDECUTL(SDECAPTID)
  1. .S PROVIEN=$$GET1^DIQ(44,SDCL_",",16,"I")
  1. .D REQSET^SDEC07A($P(SDAPTYP,";",1),PROVIEN,"",2,SDECTYP,SDECNOT,SAVESTRT,SDRES) ;651 added SAVESTRT
  1. .I $G(NEWPID) D
  1. ..S CONSIEN=$P(SDAPTYP,";",1)
  1. ..S PIDHIEN=$O(^SDEC(409.87,"B",CONSIEN,0))
  1. ..S CSFDA(409.871,"+1,"_PIDHIEN_",",.01)=$$NOW^XLFDT
  1. ..S CSFDA(409.871,"+1,"_PIDHIEN_",",1)=$G(NEWPID)
  1. ..S CSFDA(409.871,"+1,"_PIDHIEN_",",2)=$$GET1^DIQ(200,SDUSER,.01,"E")
  1. ..D UPDATE^DIE("","CSFDA","CSSIEN","ERR") K CSFDA
  1. ;
  1. I $P(SDAPTYP,";",2)="SDEC(409.85," D ;update APPT
  1. .K SDECFDA,SDECMSG,SDECWP
  1. .D:'$E(SDF,2) AROPEN^SDECAR("",SDECAPTID)
  1. .S SDIEN=$P(SDAPTYP,";",1)
  1. .S SDECFDA(409.85,SDIEN_",",13)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.1)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.2)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.3)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.4)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.5)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.6)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.7)="@"
  1. .S SDECFDA(409.85,SDIEN_",",13.8)="@"
  1. .S PIDCHANGEVERIF=$S(SDECTYP="C":0,SDECTYP="PC":1,1:"")
  1. .S SDECFDA(409.85,SDIEN_",",49)=PIDCHANGEVERIF
  1. .S:$G(EASTRCKNGNMBR)'="" SDECFDA(409.85,SDIEN_",",100)=EASTRCKNGNMBR
  1. .; If Canc Don't Re-Open and no existing Disp Code
  1. .I ($$GET1^DIQ(409.2,SDECCR,5,"I")=0),($$GET1^DIQ(409.85,SDIEN,21,"I")="") D
  1. ..S SDECFDA(409.85,SDIEN_",",19)=$P($$GET1^DIQ(409.84,SDECAPTID,.12,"I"),".",1)
  1. ..S SDECFDA(409.85,SDIEN_",",20)=$$GET1^DIQ(409.84,SDECAPTID,.121,"I")
  1. ..S SDECFDA(409.85,SDIEN_",",21)=$O(^SDEC(409.853,"B","CANCELLED NOT RE-OPENED",""))
  1. .D UPDATE^DIE("","SDECFDA","ARRET","ERRMSG")
  1. .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
  1. Q
  1. ;
  1. CANEVT(SDECPAT,SDECSTART,SDECSC) ;EP Called by SDEC CANCEL APPOINTMENT
  1. ;when Appt cancelled via PIMS interface.
  1. ;Propagates cancel to SDECAPPT & raises refresh event to running GUI clients
  1. N SDECFOUND,SDECRES
  1. Q:+$G(SDECNOEV)
  1. Q:'+$G(SDECSC)
  1. S SDECFOUND=0
  1. I $D(^SDEC(409.831,"ALOC",SDECSC)) S SDECRES=$O(^SDEC(409.831,"ALOC",SDECSC,0)) S SDECFOUND=$$CANEVT1(SDECRES,SDECSTART,SDECPAT)
  1. I SDECFOUND D CANEVT3(SDECRES) Q
  1. Q
  1. ;
  1. CANEVT1(SDECRES,SDECSTART,SDECPAT) ;
  1. ;Get Appt ID in SDECAPT
  1. ;If found, call SDECCAN(SDECAPPT) and return 1
  1. ;else return 0
  1. N SDECFOUND,SDECAPPT
  1. S SDECFOUND=0
  1. Q:'+SDECRES SDECFOUND
  1. Q:'$D(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART)) SDECFOUND
  1. S SDECAPPT=0 F S SDECAPPT=$O(^SDEC(409.84,"ARSRC",SDECRES,SDECSTART,SDECAPPT)) Q:'+SDECAPPT D Q:SDECFOUND
  1. . S SDECNOD=$G(^SDEC(409.84,SDECAPPT,0)) Q:SDECNOD=""
  1. . I $P(SDECNOD,U,5)=SDECPAT,$P(SDECNOD,U,12)="" S SDECFOUND=1 Q
  1. I SDECFOUND,+$G(SDECAPPT) D SDECCAN(SDECAPPT,,,,,,1)
  1. Q SDECFOUND
  1. ;
  1. CANEVT3(SDECRES) ;
  1. ;Call RaiseEvent to notify GUI clients
  1. Q
  1. N SDECRESN
  1. S SDECRESN=$G(^SDEC(409.831,SDECRES,0))
  1. Q:SDECRESN=""
  1. S SDECRESN=$P(SDECRESN,"^")
  1. Q
  1. ;
  1. CANCEL(BSDR) ;EP; called to cancel appt
  1. ; Make call using: S ERR=$$CANCEL^SDEC08(.ARRAY)
  1. ;
  1. ; Input Array -
  1. ; BSDR("PAT") = ien of patient file 2
  1. ; BSDR("CLN") = ien of clinic file 44
  1. ; BSDR("TYP") = C for canceled by clinic; PC for patient canceled
  1. ; BSDR("ADT") = appointment date and time
  1. ; BSDR("CDT") = cancel date and time
  1. ; BSDR("USR") = user who canceled appt
  1. ; BSDR("CR") = cancel reason - pointer to file 409.2
  1. ; BSDR("NOT") = cancel remarks - optional notes to 160 characters
  1. ;
  1. ;Output: error status and message
  1. ; = 0 or null: everything okay
  1. ; = 1^message: error and reason
  1. ;
  1. I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
  1. I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
  1. I ($G(BSDR("TYP"))'="C"),($G(BSDR("TYP"))'="PC") Q 1_U_"Cancel Status error: "_$G(BSDR("TYP"))
  1. 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
  1. 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
  1. I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Canceled Appt Error: "_$G(BSDR("USR"))
  1. I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))
  1. ;
  1. NEW IEN,DIE,DA,DR,SDMODE,HLAPTIEN ;*zeb+1 722 2/21/19 save IEN for canceling appt
  1. S IEN=$$SCIEN^SDECU2(BSDR("PAT"),BSDR("CLN"),BSDR("ADT")),HLAPTIEN=IEN
  1. I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
  1. ;
  1. 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")
  1. ;
  1. ; remember before status
  1. NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
  1. S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
  1. S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
  1. D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
  1. ;
  1. ; get user who made appt and date appt made from ^SC
  1. ; because data in ^SC will be deleted
  1. NEW USER,DATE
  1. S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
  1. S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
  1. ;
  1. ; update file 2 info
  1. NEW DIE,DA,DR
  1. N SDFDA,SDIEN,SDMSG
  1. S SDFDA="SDFDA(2.98,SDT_"",""_DFN_"","")"
  1. S @SDFDA@(3)=BSDR("TYP")
  1. S @SDFDA@(14)=BSDR("USR")
  1. S @SDFDA@(15)=BSDR("CDT")
  1. S:+$G(BSDR("CR")) @SDFDA@(16)=BSDR("CR")
  1. S:$G(BSDR("NOT"))]"" @SDFDA@(17)=$E(BSDR("NOT"),1,160)
  1. S @SDFDA@(19)=USER
  1. S @SDFDA@(20)=DATE
  1. D UPDATE^DIE("","SDFDA") ; ICR #7030 wtc 756 6/15/2020
  1. N SDPCE
  1. S SDPCE=$P($G(^DPT(DFN,"S",SDT,0)),U,20) ; ICR #7030 wtc 756 6/15/2020
  1. D:+SDPCE EN^SDCODEL(SDPCE,2,"","CANCEL") ;remove OUTPATIENT ENCOUNTER link ;*zeb 10/25/18 722 pass in correct SDMODE and delete source
  1. S $P(^SC(BSDR("CLN"),"S",BSDR("ADT"),1,HLAPTIEN,0),"^",9)="C"
  1. ; call event driver
  1. S SDATA=SDDA_U_DFN_U_SDT_U_SDCL
  1. D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL) ;*zeb 10/25/18 722 uncomment to re-enable event driver
  1. Q 0
  1. ;
  1. UNDOCANA(SDECY,SDECAPTID) ;Undo Cancel Appointment
  1. ;UNDOCANA(SDECY,SDECAPTID) external parameter tag in SDEC
  1. ;called by SDEC UNCANCEL APPT
  1. ; SDECAPTID = ien of appointment in SDEC APPOINTMENT (^SDECAPPT) file 409.84
  1. N SDECDAM,SDECDEC,SDECI,SDECNOD,SDECPATID,SDECSTART,SDECNOTE,SDECWKIN
  1. S SDECNOEV=1 ;Don't execute SDEC CANCEL APPOINTMENT protocol ;is this used?
  1. ;
  1. S SDECI=0
  1. K ^TMP("SDEC",$J)
  1. S SDECY="^TMP(""SDEC"","_$J_")"
  1. S ^TMP("SDEC",$J,SDECI)="T00020ERRORID"_$C(30)
  1. I '+SDECAPTID D ERR(SDECI+1,"Invalid Appointment ID.",+$G(SDECAPTID),0) Q ;BI/SD*5.3*740
  1. I '$D(^SDEC(409.84,SDECAPTID,0)) D ERR(SDECI+1,"Invalid Appointment ID",+SDECAPTID,0) Q ;BI/SD*5.3*740
  1. ;Make sure appointment is cancelled
  1. I $$GET1^DIQ(409.84,SDECAPTID_",",.12)="" D ERR(SDECI+1,"Appointment is not Cancelled.",+SDECAPTID,0) Q ;BI/SD*5.3*740
  1. S SDECNOD=^SDEC(409.84,SDECAPTID,0)
  1. ;appts cancelled by patient cannot be un-cancelled. /* removed 9/17/2010 */
  1. ;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
  1. ;get appointment data
  1. S SDECNOD=^SDEC(409.84,SDECAPTID,0)
  1. S SDECDAM=$P(SDECNOD,U,9) ;date appt made
  1. S SDECDEC=$P(SDECNOD,U,8) ;data entry clerk
  1. S SDECLEN=$P(SDECNOD,U,18) ;length of appt in minutes
  1. ;
  1. ; Get entire note from Appointment file. 756 wtc 1/25/2019
  1. ;
  1. ;S SDECNOTE=$G(^SDEC(409.84,SDECAPTID,1,1,0)) ;note from SDEC APPOINTMENT
  1. S SDECNOTE="" N I F I=1:1 Q:'$D(^SDEC(409.84,SDECAPTID,1,I,0)) S SDECNOTE=SDECNOTE_^(0)_$C(13) ;
  1. ;
  1. S SDECPATID=$P(SDECNOD,U,5) ;pointer to VA PATIENT file 2
  1. S SDECSC1=$P($G(SDECNOD),U,7) ;resource
  1. S SDECSTART=$P(SDECNOD,U) ;appt start time
  1. S SDECWKIN=$P($G(SDECNOD),U,13) ;walk-in
  1. ;lock SDEC node
  1. ; changed line below to use SDECAPTID instead of SDECPATID ; pwc *745 7/16/2020
  1. 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
  1. ;un-cancel SDEC APPOINTMENT
  1. D SDECUCAN^SDEC08A(SDECAPTID) ;moved to ^SDEC08A because of XINDEX size *756 PWC
  1. 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
  1. . S SDECLOC=""
  1. . S SDECNOD=^SDEC(409.831,SDECSC1,0)
  1. . S SDECLOC=$P(SDECNOD,U,4) ;HOSPITAL LOCATION ;support for single HOSPITAL LOCATION in SDEC RESOURCE
  1. . I SDECLOC="" S SDECLOC=$$SDCL^SDECUTL(SDECAPTID) ;HOSPITAL LOCATION
  1. . Q:'+SDECLOC
  1. . ;un-cancel patient appointment and re-instate clinic appointment
  1. . S SDECZ=""
  1. . D APUCAN^SDEC08A(.SDECZ,SDECLOC,SDECPATID,SDECSTART,SDECDAM,SDECDEC,SDECLEN,SDECNOTE,SDECSC1,SDECWKIN) ;moved to ^SDEC08A because of XINDEX size *756 PWC
  1. L -^SDEC(409.84,SDECAPTID) ;changed SDECPATID to SDECAPTID - pwc *745
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=""_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=$C(31)
  1. Q
  1. ;
  1. 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
  1. S SDECERR=$TR(SDECERR,"^","~")
  1. S ^TMP("SDEC",$J,SDECI)=SDECERR_$C(30)
  1. S SDECI=SDECI+1
  1. S ^TMP("SDEC",$J,SDECI)=$C(31)
  1. I $G(LOCK)=1 L -^SDEC(409.84,SDECAPTID) ;BI/SD*5.3*740 ;changed SDECPATID to SDECAPTID - pwc *745
  1. Q
  1. ;
  1. ETRAP ;EP Error trap entry
  1. D ^%ZTER
  1. I '$D(SDECI) N SDECI S SDECI=999999
  1. S SDECI=SDECI+1
  1. D ERR(SDECI,"SDEC08 Error")
  1. Q