- 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 Feb 19, 2025@00:16:28 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