SDESBLKANDMOVE ;ALB/TAW,MGD,LAB - BLOCK AND MOVE ;May 09,2023
;;5.3;Scheduling;**797,799,800,801,803,804,805,807,819,820,843**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^HOLIDAY is supported by IA #10038
; Reference to ^VA(200 is supported by IA #10060
;
APPTBLOCKMOVE(RETURN,APPTIEN,TORES,TODTNET,EASTRCKNGNMBR) ;
N POP,SDAPPT,TODTFM,FROMRES,APPTARY,FN,SDECAPPTIENS,NEWAPPTIEN,TODTFMEND,TOTIMESCALE,SDTOCLIEN,CLINBEG,SDDUZ
N FROMDTFM,FROMDTNET,TIMESCALEDIFF,SDSLOT2BLK,FROMTIMESCALE,SDORGCLIEN,TOENDDTFM
N ENDDTFM,SDSEGMENTS,APPTLENGTH,SDPID,SDDATA44SLFROM,SDDATA44SLTO,CLINBEGFROM,CLINBEGTO,OVB
S (POP,NEWAPPTIEN,TIMESCALEDIFF)=0,TODTFMEND=""
D VALIDATEINPUT
I 'POP D LOADAPPTDATA(.FN,.APPTARY,.SDECAPPTIENS)
I 'POP D SLOTCOUNT
I 'POP D VALIDATE
I 'POP D COMPARETIMESCALE
I 'POP D CHKAVAILABILITY^SDESBLKANDMOVE1(TORES,SDTOCLIEN,TODTNET,"T",TODTFM)
I 'POP D CHKAVAILABILITY^SDESBLKANDMOVE1(FROMRES,SDORGCLIEN,FROMDTNET,"F",FROMDTFM)
I 'POP D TOOVBCHECK^SDESBLKANDMOVE1(SDTOCLIEN,TODTFM,.APPTARY,FN,SDECAPPTIENS,.POP,.SDAPPT,.OVB)
I 'POP D APPDEL
I 'POP D
.I APPTLENGTH<TOTIMESCALE D APPADD(APPTIEN,TODTFM,TOTIMESCALE,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS) Q
.I APPTLENGTH>=TOTIMESCALE D APPADD(APPTIEN,TODTFM,APPTLENGTH,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS)
I 'POP D PREBLOCK^SDESBLKANDMOVE1(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SLFROM,.SDSEGMENTS)
I 'POP D
.I NEWAPPTIEN S SDAPPT("BlockAndMove","NewAppointmentIEN")=NEWAPPTIEN
.E D ERRLOG^SDESJSON(.SDAPPT) ;This should not happen but..force unknown error
K ^TMP("SDEC57",$J)
D BUILDER^SDESBLKANDMOVE1
Q
;
VALIDATEINPUT ;Validate input parameters from the APPTBLOCKMOVE entry point
S APPTIEN=$G(APPTIEN)
I APPTIEN="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,3)
I APPTIEN'="",'$D(^SDEC(409.84,APPTIEN,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,4)
;
S TORES=$G(TORES)
I TORES="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,69)
I TORES'="",'$D(^SDEC(409.831,TORES,0)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,70)
;
S TODTNET=$G(TODTNET)
I TODTNET="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,76)
I TODTNET'="" D
.S TODTFM=$$NETTOFM^SDECDATE(TODTNET)
.I TODTFM=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,77) Q
.I $P(TODTFM,".")<DT S POP=1 D ERRLOG^SDESJSON(.SDAPPT,71)
;validate EAS Tracking Number
S EASTRCKNGNMBR=$TR($G(EASTRCKNGNMBR),"^"," ")
I $L(EASTRCKNGNMBR) S EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
I EASTRCKNGNMBR=-1 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,142)
; validate DUZ
S SDDUZ=$G(SDDUZ,DUZ)
I SDDUZ="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Missing DUZ")
I SDDUZ,'$$FIND1^DIC(200,,"A",DUZ,"","","SDERR") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Invalid DUZ")
Q
;
LOADAPPTDATA(FN,APPTARY,SDECAPPTIENS) ;Load variables used throughout B&M
N SDMSG
S FN=409.84,SDECAPPTIENS=APPTIEN_","
D GETS^DIQ(FN,SDECAPPTIENS,"**","IE","APPTARY","SDMSG") ;Data from SDEC APPOINTMENT file 409.84 for a record
S FROMDTFM=$G(APPTARY(FN,SDECAPPTIENS,.01,"I"))
S FROMDTNET=$$FMTONET^SDECDATE(FROMDTFM)
S ENDDTFM=$G(APPTARY(FN,SDECAPPTIENS,.02,"I"))
S FROMRES=$G(APPTARY(FN,SDECAPPTIENS,.07,"I")) ;Originating Resource IEN
S SDORGCLIEN=$$GET1^DIQ(409.831,FROMRES,.04,"I") ;Originating Clinic IEN
S SDTOCLIEN=$$GET1^DIQ(409.831,TORES,.04,"I") ;Destination Clinic IEN
S SDPID=$G(APPTARY(FN,SDECAPPTIENS,.2,"E"))
; Load Resource & Clinic info
S SDDATA44SLFROM=$G(^SC(SDORGCLIEN,"SL"))
S CLINBEGFROM=$P(SDDATA44SLFROM,U,3)
I CLINBEGFROM="" S CLINBEGFROM=8
S CLINBEGFROM=$$PADCLTIME^SDESUTIL(CLINBEGFROM)
S SDDATA44SLTO=$G(^SC(SDTOCLIEN,"SL"))
S CLINBEGTO=$P(SDDATA44SLTO,U,3)
I CLINBEGTO="" S CLINBEGTO=8
S CLINBEGTO=$$PADCLTIME^SDESUTIL(CLINBEGTO)
S FROMTIMESCALE=$P(^SDEC(409.831,FROMRES,0),"^",3)
S TOTIMESCALE=$P(^SDEC(409.831,TORES,0),"^",3)
I FROMTIMESCALE="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
I TOTIMESCALE="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
I 'POP S TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,TOTIMESCALE,0) ;Appt end time at the Destination clinic
D:'POP SDSEGMENTS
Q
;
VALIDATE ; Simple validation
N FROMDTFMPAD,TODTFMPAD,ENDDTFMPAD,SDDOW,HASPATRN
; From Appt must have same Dt Time as new appt.
S FROMDTFMPAD=$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2))
S TODTFMPAD=$$PADFMTIME^SDESUTIL($P(TODTFM,".",2))
S ENDDTFMPAD=$$PADFMTIME^SDESUTIL($P(ENDDTFM,".",2))
;I $P(FROMDTFM,".")'=$P(TODTFM,".") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Appointment dates must match")
I 'POP,+FROMDTFMPAD'=+TODTFMPAD S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Appointment times must match")
;
; Verify Start/End time of appt is on a single day
I +ENDDTFMPAD<+FROMDTFMPAD S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Appointment must start & end on a single day") Q
;Current Appt must be in a 'scheduled' status only. Can not be checked in, cancelled, etc.
N APPTSTAT
S APPTSTAT=$$APPTSTS^SDEC50(APPTIEN,"","")
I APPTSTAT["CANCELLED"!(APPTSTAT["NO-SHOW")!(APPTSTAT["CHECKED IN")!(APPTSTAT["CHECKED OUT") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,78)
; Check for restricted From or To clinic
I '$$PRIVUSR^SDESCLINICUTIL(SDORGCLIEN,DUZ) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Originating clinic")
I '$$PRIVUSR^SDESCLINICUTIL(SDTOCLIEN,DUZ) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Destination clinic")
; Don't allow B&M to prior to the start of the clinic availability
I +$E($P(TODTFM,".",2)_"0000",1,4)<CLINBEGTO S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of Destination clinic")
;Check if able to schedule on holiday
I $$GET1^DIQ(44,SDTOCLIEN_",",1918.5,"I")'="Y",$$FIND1^DIC(40.5,,"B",$P(TODTFM,".",1),"","","SDERR") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Scheduling on holidays is not permitted")
S SDDOW=$$DOW^XLFDT($P(TODTFM,".",1),1)
; Does Destination clinic have an availability pattern defined for this date
;S HASPATRN=$$HASPATRN^SDESBLKANDMOVE1(SDTOCLIEN,SDDOW,$P(TODTFM,".",1))
;I HASPATRN=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date")
Q
;
COMPARETIMESCALE ;Compare the Time Scale of the Clinic Resource from the original appt vs new appt
;The Time Scale of the original appointment can not be greater than the new appointment
; Can't squeeze a 30 min appt into a 10 min slot.
I 'POP,FROMTIMESCALE>TOTIMESCALE S POP=1 D ERRLOG^SDESJSON(.SDAPPT,74) Q
; Check for clinics being multiples
I TOTIMESCALE#FROMTIMESCALE'=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic not a multiple of Originating clinic")
Q
;
SDSEGMENTS ; Build local array of slots with SCHEDULE and EVALUATE nodes
N FRSTTMFMADJ,TOENDTMFMADJ,SDSEGSTTIM,SDSEGENDTIM,PADFROMDTFM,PADENDDTFM,CLINID
;
; Adjust new appt end time when moving a 60 min appt into a 30 min appt slot
S APPTLENGTH=$$FMDIFF^XLFDT(ENDDTFM,FROMDTFM,2)/60 ;actual length current appt in min
I APPTLENGTH'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Invalid appointment length calculation") Q
I APPTLENGTH>TOTIMESCALE S TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,APPTLENGTH,0) ;Appt end time at the Destination clinic
I TOENDDTFM=-1!($P(TODTFM,".",1)'=$P(TOENDDTFM,".",1)) S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"New appointment crosses midnight") Q
;
; Init vars for the Destination clinic & appointment
S PADFROMDTFM=$$PADFMTIME^SDESUTIL($P(TODTFM,".",2))
S PADENDDTFM=$$PADFMTIME^SDESUTIL($P(TOENDDTFM,".",2))
S FRSTTMFMADJ=$P($$FMADD^XLFDT(TODTFM,0,0,1,0),".",2)
S FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
S TOENDTMFMADJ=$P($$FMADD^XLFDT(TOENDDTFM,0,0,1,0),".",2)
S TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
S CLINID="T" ; To Clinic
; Load To clinic segments from T node of the Hospital Location file
D SEGARRAY(SDTOCLIEN,TOTIMESCALE,TODTFM,CLINBEGTO,CLINID)
Q:POP
; Determine the evaluation start time
S SDSEGSTTIM=$O(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
; Would we ever have an appt prior to the defined clinic start time???
I SDSEGSTTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of destination clinic") Q
; Appt start time = segment start time
I +PADFROMDTFM=SDSEGSTTIM S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
I +PADFROMDTFM>SDSEGSTTIM,(+PADFROMDTFM<SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)) S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
; Appt starts after the segment ends
I +PADFROMDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM) S SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
; Determine the evaluation end time
S SDSEGENDTIM=$O(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
I SDSEGENDTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in Originating clinic for evaluation") Q
; Appt end time fall within the segment
I +PADENDDTFM>SDSEGENDTIM,+PADENDDTFM<=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
; Appt end time > Segment end time
I +PADENDDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
; Appt end time = Segment end time
I +PADENDDTFM=SDSEGENDTIM S $P(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
;
; If additional time needs to be blocked at the originating clinic to account for moving from a 30 min clinic
; to a 60 min clinic.
I FROMTIMESCALE<TOTIMESCALE D
.I TODTFM<FROMDTFM S FROMDTFM=TODTFM
.I TOENDDTFM>ENDDTFM S ENDDTFM=TOENDDTFM
;
; Init variables for the Originating clinic and appointment
S PADFROMDTFM=$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2))
S FRSTTMFMADJ=$P($$FMADD^XLFDT(FROMDTFM,0,0,1,0),".",2) ;increment by 1 min
S FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
S PADENDDTFM=$$PADFMTIME^SDESUTIL($P(ENDDTFM,".",2))
S TOENDTMFMADJ=$P($$FMADD^XLFDT(ENDDTFM,0,0,1,0),".",2) ;increment by 1 min
S TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
S CLINID="F" ; From Clinic
; Load From clinic segments from T node of the Hospital Location file
D SEGARRAY(SDORGCLIEN,FROMTIMESCALE,FROMDTFM,CLINBEGFROM,CLINID)
Q:POP
; Determine the evaluation start time
S SDSEGSTTIM=$O(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
; Would we ever have an appt prior to the defined clinic start time???
I SDSEGSTTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot begin time in originating clinic for evaluation") Q
; Appt start time = segment start time
I +PADFROMDTFM=SDSEGSTTIM S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
I +PADFROMDTFM>SDSEGSTTIM,(+PADFROMDTFM<SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)) S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
; Appt starts after the segment ends
I +PADFROMDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM) S SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
; Determine the evaluation end time
S SDSEGENDTIM=$O(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
I SDSEGENDTIM="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in originating clinic for evaluation") Q
; Appt end time fall within the segment
I +PADENDDTFM>SDSEGENDTIM,+PADENDDTFM<=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
; Appt end time > Segment end time
I +PADENDDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM) S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
; Appt end time = Segment end time
I +PADENDDTFM=SDSEGENDTIM S $P(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
Q
;
SEGARRAY(CLIEN,TIMESCALE,FROMDTFM,CLINBEG,CLINID) ; Create local array to hold segments for validation comparisons
N PATRNIEN,SDDOW,SDINDX,SDENDTIME,SDSLDATA,STOP,TINDX,I
S PATRNIEN=$P(FROMDTFM,".",1)
I '$D(^SC(CLIEN,"T",PATRNIEN,0)) D Q:PATRNIEN'>0
.S SDDOW=$$DOW^XLFDT(PATRNIEN,1)
.F S PATRNIEN=$O(^SC(CLIEN,"T",PATRNIEN),-1) Q:PATRNIEN=0 Q:$$DOW^XLFDT(PATRNIEN,1)=SDDOW
.I PATRNIEN'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Availability definition not found")
; Loop to find start time definition
S SDINDX=0
F S SDINDX=$O(^SC(CLIEN,"T",PATRNIEN,2,SDINDX)) Q:'SDINDX D
.S SDSLDATA=^SC(CLIEN,"T",PATRNIEN,2,SDINDX,0)
.S SDENDTIME=$$FMADD^XLFDT(DT_"."_$P(SDSLDATA,U,1),,,TIMESCALE)
.S SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+$P(SDSLDATA,U,1))=+$$PADFMTIME^SDESUTIL($P(SDENDTIME,".",2))_"^"_$P(SDSLDATA,U,2)
; Check and build Teal area
S SDINDX=0
S SDINDX=$O(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX))
Q:SDINDX=CLINBEG
S STOP=""
F I=1:1 D Q:STOP
.S TINDX=$$FMADD^XLFDT(DT_"."_$$PADLENGTH^SDESUTIL(SDINDX,"0",4,"F"),,,-TIMESCALE)
.I $P(TINDX,".",1)'=DT S STOP=1 Q
.I $P(TINDX,".",2)=24 D Q
..S STOP=1,SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",0)=SDINDX_"^-"
.S TINDX=+$$PADFMTIME^SDESUTIL($P(TINDX,".",2))
.I +TINDX<=CLINBEG S STOP=1,TINDX=CLINBEG
.S SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+TINDX)=SDINDX_"^-"
.S SDINDX=+TINDX
Q
;
SLOTCOUNT ;
; Verifying that we don't have more than the max allowable slots defined for the period of time we are reviewing
I $$IDTIMESLOT^SDESBLKANDMOVE1(SDORGCLIEN,1,"F") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"More than 1 appointment slot in Originating clinic") Q:POP
Q
;
APPDEL ;Call APPDEL RPC to cancel the current appointment
;Input:
; SDECAPPTIEN [REQ] - IEN of appointment to cancel
;Assume:
; SDAPPT - Array of data returned by the RPC
;Output:
; Any errors logged by call to APPDEL RPC
N RET,TEXT,SDCANRSN,SDUSRNOTE,SDCANDT,SDAPTYP,SDF
S SDCANRSN=$$FIND1^DIC(409.2,,"B","BLOCK AND MOVE","","","SDERR")
I 'SDCANRSN S SDCANRSN=""
S SDF=""
S SDAPTYP=$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))
;I $P(SDAPTYP,";",2)="SD(403.5," S SDF=3
D APPDEL^SDEC08(.RET,APPTIEN,"C",SDCANRSN,,,,,SDF,,,$G(EASTRCKNGNMBR))
S TEXT=$G(^TMP("SDEC08",$J,"APPDEL",1))
S TEXT=$P(TEXT,$C(30))
I TEXT'="" D
.S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,TEXT,"APPDEL^SDESAPPTSET")
K ^TMP("SDEC08",$J)
Q
;
APPADD(SDECAPPTIEN,SDECSTART,SDECLEN,SDECRES,SDECEND,FN,APPTARY,SDECAPPTIENS) ;entry point before calling APPADD^SDEC07
;Input:
; SDECAPPTIEN [REQ] - The IEN from SDEC APPOINTMENT File #409.84
; SDECSTART [REQ] - The internal format of Appointment Start Time
; SDECLEN [REQ] - Appointment length based on Time Scale from 409.831
; SDECRES [REQ] - The IEN from SDEC RESOURCE File #409.831.
; SDECEND [REQ] - Appointment end dt/tm in FM format
;
;Assume:
; APPTARY - Array of data from 409.84 for SDECAPPTIEN
; SDAPPT - Array of data returned by the RPC
;
;Output:
; Errors logged by call to APPADD or set NEWAPPTIEN
;
N SDRET,SDDFN,SDECNOTE,SDECATID,SDECCR,SDDDT,SDAPTYP,SDCL,SDEL,SDECY
K ^TMP("SDEC07",$J)
S SDDFN=$G(APPTARY(FN,SDECAPPTIENS,.05,"I")) ;Patient ID/DFN
S SDCL=$P($G(^SDEC(409.831,+SDECRES,0)),U,4) ;Clinic IEN pointer to HOSPITAL LOCATION file 44
;S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;Appointment end time if SDECEND passed in as NULL
S SDECNOTE=$G(APPTARY(FN,SDECAPPTIENS,1,1)) ;Note
S SDECATID=$G(APPTARY(FN,SDECAPPTIENS,.13,"E")) ;WALKIN - WALKIN flag y=YES; n=NO default to NO
I SDECATID=""!(SDECATID="NO") S SDECATID=$P($G(^DPT(SDDFN,"S",SDECSTART,0)),U,7) ;get the purpose of visit in the patient file if NULL in file 409.84
S SDECATID=$S(SDECATID="YES"!(SDECATID=4):"WALKIN",1:SDECATID)
S SDECCR=$S(SDECATID="WALKIN":0,1:1) ;routing slip
S SDDDT=$G(APPTARY(FN,SDECAPPTIENS,.02,"I")) ;desired date of appointment
S SDAPTYP=$$GET1^DIQ(FN,SDECAPPTIENS,.22,"E")
S SDAPTYP=$S(SDAPTYP="APPT":"A",SDAPTYP="RECALL":"R",SDAPTYP="CONSULT":"C",SDAPTYP="EWL":"E",1:"")
S SDAPTYP=SDAPTYP_"|"_$P($$GET1^DIQ(FN,SDECAPPTIENS,.22,"I"),";")
S SDEL=$P($G(^DPT(SDDFN,.36)),U,1) ;Current Eligibility Code
K SDECY
D APPADD^SDEC07(.SDECY,$$FMTE^XLFDT(SDECSTART),$$FMTE^XLFDT(SDECEND),SDDFN,SDECRES,SDECLEN,$G(SDECNOTE),SDECATID,,,SDPID,,,,,SDAPTYP,,,SDCL,,,,,OVB,,SDEL,$G(EASTRCKNGNMBR)) ;ADD NEW APPOINTMENT
;
N CNTR,ERROR
S ERROR=""
S CNTR=$O(^TMP("SDEC07",$J,0))
I CNTR S ERROR=$G(^TMP("SDEC07",$J,CNTR))
S ERROR=$$CTRL^XMXUTIL1(ERROR)
I $P(ERROR,"^",2)'="" D
.S POP=1
.D ERRLOG^SDESJSON(.SDAPPT,52,$P(ERROR,"^",2),"APPADD^SDESAPPTSET")
E D
.S NEWAPPTIEN=$P(ERROR,"^",1)
.I $E(SDAPTYP,1)="R",$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))'="" D
..N SDBM
..S SDBM(409.84,NEWAPPTIEN_",",.22)=$G(APPTARY(FN,SDECAPPTIENS,.22,"I"))
..D UPDATE^DIE("","SDBM","SDERR")
;
K ^TMP("SDEC07",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESBLKANDMOVE 16798 printed Dec 13, 2024@02:55:50 Page 2
SDESBLKANDMOVE ;ALB/TAW,MGD,LAB - BLOCK AND MOVE ;May 09,2023
+1 ;;5.3;Scheduling;**797,799,800,801,803,804,805,807,819,820,843**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^HOLIDAY is supported by IA #10038
+5 ; Reference to ^VA(200 is supported by IA #10060
+6 ;
APPTBLOCKMOVE(RETURN,APPTIEN,TORES,TODTNET,EASTRCKNGNMBR) ;
+1 NEW POP,SDAPPT,TODTFM,FROMRES,APPTARY,FN,SDECAPPTIENS,NEWAPPTIEN,TODTFMEND,TOTIMESCALE,SDTOCLIEN,CLINBEG,SDDUZ
+2 NEW FROMDTFM,FROMDTNET,TIMESCALEDIFF,SDSLOT2BLK,FROMTIMESCALE,SDORGCLIEN,TOENDDTFM
+3 NEW ENDDTFM,SDSEGMENTS,APPTLENGTH,SDPID,SDDATA44SLFROM,SDDATA44SLTO,CLINBEGFROM,CLINBEGTO,OVB
+4 SET (POP,NEWAPPTIEN,TIMESCALEDIFF)=0
SET TODTFMEND=""
+5 DO VALIDATEINPUT
+6 IF 'POP
DO LOADAPPTDATA(.FN,.APPTARY,.SDECAPPTIENS)
+7 IF 'POP
DO SLOTCOUNT
+8 IF 'POP
DO VALIDATE
+9 IF 'POP
DO COMPARETIMESCALE
+10 IF 'POP
DO CHKAVAILABILITY^SDESBLKANDMOVE1(TORES,SDTOCLIEN,TODTNET,"T",TODTFM)
+11 IF 'POP
DO CHKAVAILABILITY^SDESBLKANDMOVE1(FROMRES,SDORGCLIEN,FROMDTNET,"F",FROMDTFM)
+12 IF 'POP
DO TOOVBCHECK^SDESBLKANDMOVE1(SDTOCLIEN,TODTFM,.APPTARY,FN,SDECAPPTIENS,.POP,.SDAPPT,.OVB)
+13 IF 'POP
DO APPDEL
+14 IF 'POP
Begin DoDot:1
+15 IF APPTLENGTH<TOTIMESCALE
DO APPADD(APPTIEN,TODTFM,TOTIMESCALE,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS)
QUIT
+16 IF APPTLENGTH>=TOTIMESCALE
DO APPADD(APPTIEN,TODTFM,APPTLENGTH,TORES,TOENDDTFM,FN,.APPTARY,SDECAPPTIENS)
End DoDot:1
+17 IF 'POP
DO PREBLOCK^SDESBLKANDMOVE1(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SLFROM,.SDSEGMENTS)
+18 IF 'POP
Begin DoDot:1
+19 IF NEWAPPTIEN
SET SDAPPT("BlockAndMove","NewAppointmentIEN")=NEWAPPTIEN
+20 ;This should not happen but..force unknown error
IF '$TEST
DO ERRLOG^SDESJSON(.SDAPPT)
End DoDot:1
+21 KILL ^TMP("SDEC57",$JOB)
+22 DO BUILDER^SDESBLKANDMOVE1
+23 QUIT
+24 ;
VALIDATEINPUT ;Validate input parameters from the APPTBLOCKMOVE entry point
+1 SET APPTIEN=$GET(APPTIEN)
+2 IF APPTIEN=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,3)
+3 IF APPTIEN'=""
IF '$DATA(^SDEC(409.84,APPTIEN,0))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,4)
+4 ;
+5 SET TORES=$GET(TORES)
+6 IF TORES=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,69)
+7 IF TORES'=""
IF '$DATA(^SDEC(409.831,TORES,0))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,70)
+8 ;
+9 SET TODTNET=$GET(TODTNET)
+10 IF TODTNET=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,76)
+11 IF TODTNET'=""
Begin DoDot:1
+12 SET TODTFM=$$NETTOFM^SDECDATE(TODTNET)
+13 IF TODTFM=-1
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,77)
QUIT
+14 IF $PIECE(TODTFM,".")<DT
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,71)
End DoDot:1
+15 ;validate EAS Tracking Number
+16 SET EASTRCKNGNMBR=$TRANSLATE($GET(EASTRCKNGNMBR),"^"," ")
+17 IF $LENGTH(EASTRCKNGNMBR)
SET EASTRCKNGNMBR=$$EASVALIDATE^SDESUTIL(EASTRCKNGNMBR)
+18 IF EASTRCKNGNMBR=-1
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,142)
+19 ; validate DUZ
+20 SET SDDUZ=$GET(SDDUZ,DUZ)
+21 IF SDDUZ=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Missing DUZ")
+22 IF SDDUZ
IF '$$FIND1^DIC(200,,"A",DUZ,"","","SDERR")
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Invalid DUZ")
+23 QUIT
+24 ;
LOADAPPTDATA(FN,APPTARY,SDECAPPTIENS) ;Load variables used throughout B&M
+1 NEW SDMSG
+2 SET FN=409.84
SET SDECAPPTIENS=APPTIEN_","
+3 ;Data from SDEC APPOINTMENT file 409.84 for a record
DO GETS^DIQ(FN,SDECAPPTIENS,"**","IE","APPTARY","SDMSG")
+4 SET FROMDTFM=$GET(APPTARY(FN,SDECAPPTIENS,.01,"I"))
+5 SET FROMDTNET=$$FMTONET^SDECDATE(FROMDTFM)
+6 SET ENDDTFM=$GET(APPTARY(FN,SDECAPPTIENS,.02,"I"))
+7 ;Originating Resource IEN
SET FROMRES=$GET(APPTARY(FN,SDECAPPTIENS,.07,"I"))
+8 ;Originating Clinic IEN
SET SDORGCLIEN=$$GET1^DIQ(409.831,FROMRES,.04,"I")
+9 ;Destination Clinic IEN
SET SDTOCLIEN=$$GET1^DIQ(409.831,TORES,.04,"I")
+10 SET SDPID=$GET(APPTARY(FN,SDECAPPTIENS,.2,"E"))
+11 ; Load Resource & Clinic info
+12 SET SDDATA44SLFROM=$GET(^SC(SDORGCLIEN,"SL"))
+13 SET CLINBEGFROM=$PIECE(SDDATA44SLFROM,U,3)
+14 IF CLINBEGFROM=""
SET CLINBEGFROM=8
+15 SET CLINBEGFROM=$$PADCLTIME^SDESUTIL(CLINBEGFROM)
+16 SET SDDATA44SLTO=$GET(^SC(SDTOCLIEN,"SL"))
+17 SET CLINBEGTO=$PIECE(SDDATA44SLTO,U,3)
+18 IF CLINBEGTO=""
SET CLINBEGTO=8
+19 SET CLINBEGTO=$$PADCLTIME^SDESUTIL(CLINBEGTO)
+20 SET FROMTIMESCALE=$PIECE(^SDEC(409.831,FROMRES,0),"^",3)
+21 SET TOTIMESCALE=$PIECE(^SDEC(409.831,TORES,0),"^",3)
+22 IF FROMTIMESCALE=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
+23 IF TOTIMESCALE=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,73,"Time span")
+24 ;Appt end time at the Destination clinic
IF 'POP
SET TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,TOTIMESCALE,0)
+25 if 'POP
DO SDSEGMENTS
+26 QUIT
+27 ;
VALIDATE ; Simple validation
+1 NEW FROMDTFMPAD,TODTFMPAD,ENDDTFMPAD,SDDOW,HASPATRN
+2 ; From Appt must have same Dt Time as new appt.
+3 SET FROMDTFMPAD=$$PADFMTIME^SDESUTIL($PIECE(FROMDTFM,".",2))
+4 SET TODTFMPAD=$$PADFMTIME^SDESUTIL($PIECE(TODTFM,".",2))
+5 SET ENDDTFMPAD=$$PADFMTIME^SDESUTIL($PIECE(ENDDTFM,".",2))
+6 ;I $P(FROMDTFM,".")'=$P(TODTFM,".") S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Appointment dates must match")
+7 IF 'POP
IF +FROMDTFMPAD'=+TODTFMPAD
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,52,"Appointment times must match")
+8 ;
+9 ; Verify Start/End time of appt is on a single day
+10 IF +ENDDTFMPAD<+FROMDTFMPAD
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Appointment must start & end on a single day")
QUIT
+11 ;Current Appt must be in a 'scheduled' status only. Can not be checked in, cancelled, etc.
+12 NEW APPTSTAT
+13 SET APPTSTAT=$$APPTSTS^SDEC50(APPTIEN,"","")
+14 IF APPTSTAT["CANCELLED"!(APPTSTAT["NO-SHOW")!(APPTSTAT["CHECKED IN")!(APPTSTAT["CHECKED OUT")
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,78)
+15 ; Check for restricted From or To clinic
+16 IF '$$PRIVUSR^SDESCLINICUTIL(SDORGCLIEN,DUZ)
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Originating clinic")
+17 IF '$$PRIVUSR^SDESCLINICUTIL(SDTOCLIEN,DUZ)
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Privileged Destination clinic")
+18 ; Don't allow B&M to prior to the start of the clinic availability
+19 IF +$EXTRACT($PIECE(TODTFM,".",2)_"0000",1,4)<CLINBEGTO
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of Destination clinic")
+20 ;Check if able to schedule on holiday
+21 IF $$GET1^DIQ(44,SDTOCLIEN_",",1918.5,"I")'="Y"
IF $$FIND1^DIC(40.5,,"B",$PIECE(TODTFM,".",1),"","","SDERR")
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Scheduling on holidays is not permitted")
+22 SET SDDOW=$$DOW^XLFDT($PIECE(TODTFM,".",1),1)
+23 ; Does Destination clinic have an availability pattern defined for this date
+24 ;S HASPATRN=$$HASPATRN^SDESBLKANDMOVE1(SDTOCLIEN,SDDOW,$P(TODTFM,".",1))
+25 ;I HASPATRN=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date")
+26 QUIT
+27 ;
COMPARETIMESCALE ;Compare the Time Scale of the Clinic Resource from the original appt vs new appt
+1 ;The Time Scale of the original appointment can not be greater than the new appointment
+2 ; Can't squeeze a 30 min appt into a 10 min slot.
+3 IF 'POP
IF FROMTIMESCALE>TOTIMESCALE
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,74)
QUIT
+4 ; Check for clinics being multiples
+5 IF TOTIMESCALE#FROMTIMESCALE'=0
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic not a multiple of Originating clinic")
+6 QUIT
+7 ;
SDSEGMENTS ; Build local array of slots with SCHEDULE and EVALUATE nodes
+1 NEW FRSTTMFMADJ,TOENDTMFMADJ,SDSEGSTTIM,SDSEGENDTIM,PADFROMDTFM,PADENDDTFM,CLINID
+2 ;
+3 ; Adjust new appt end time when moving a 60 min appt into a 30 min appt slot
+4 ;actual length current appt in min
SET APPTLENGTH=$$FMDIFF^XLFDT(ENDDTFM,FROMDTFM,2)/60
+5 IF APPTLENGTH'>0
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Invalid appointment length calculation")
QUIT
+6 ;Appt end time at the Destination clinic
IF APPTLENGTH>TOTIMESCALE
SET TOENDDTFM=$$FMADD^XLFDT(TODTFM,0,0,APPTLENGTH,0)
+7 IF TOENDDTFM=-1!($PIECE(TODTFM,".",1)'=$PIECE(TOENDDTFM,".",1))
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"New appointment crosses midnight")
QUIT
+8 ;
+9 ; Init vars for the Destination clinic & appointment
+10 SET PADFROMDTFM=$$PADFMTIME^SDESUTIL($PIECE(TODTFM,".",2))
+11 SET PADENDDTFM=$$PADFMTIME^SDESUTIL($PIECE(TOENDDTFM,".",2))
+12 SET FRSTTMFMADJ=$PIECE($$FMADD^XLFDT(TODTFM,0,0,1,0),".",2)
+13 SET FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
+14 SET TOENDTMFMADJ=$PIECE($$FMADD^XLFDT(TOENDDTFM,0,0,1,0),".",2)
+15 SET TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
+16 ; To Clinic
SET CLINID="T"
+17 ; Load To clinic segments from T node of the Hospital Location file
+18 DO SEGARRAY(SDTOCLIEN,TOTIMESCALE,TODTFM,CLINBEGTO,CLINID)
+19 if POP
QUIT
+20 ; Determine the evaluation start time
+21 SET SDSEGSTTIM=$ORDER(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
+22 ; Would we ever have an appt prior to the defined clinic start time???
+23 IF SDSEGSTTIM=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Prior to start of destination clinic")
QUIT
+24 ; Appt start time = segment start time
+25 IF +PADFROMDTFM=SDSEGSTTIM
SET SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
+26 ; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
+27 IF +PADFROMDTFM>SDSEGSTTIM
IF (+PADFROMDTFM<SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM))
SET SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
+28 ; Appt starts after the segment ends
+29 IF +PADFROMDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)
SET SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
+30 ; Determine the evaluation end time
+31 SET SDSEGENDTIM=$ORDER(SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
+32 IF SDSEGENDTIM=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in Originating clinic for evaluation")
QUIT
+33 ; Appt end time fall within the segment
+34 IF +PADENDDTFM>SDSEGENDTIM
IF +PADENDDTFM<=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
SET $PIECE(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
+35 ; Appt end time > Segment end time
+36 IF +PADENDDTFM>=+SDSEGMENTS(SDTOCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
SET $PIECE(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
+37 ; Appt end time = Segment end time
+38 IF +PADENDDTFM=SDSEGENDTIM
SET $PIECE(SDSEGMENTS(SDTOCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
+39 ;
+40 ; If additional time needs to be blocked at the originating clinic to account for moving from a 30 min clinic
+41 ; to a 60 min clinic.
+42 IF FROMTIMESCALE<TOTIMESCALE
Begin DoDot:1
+43 IF TODTFM<FROMDTFM
SET FROMDTFM=TODTFM
+44 IF TOENDDTFM>ENDDTFM
SET ENDDTFM=TOENDDTFM
End DoDot:1
+45 ;
+46 ; Init variables for the Originating clinic and appointment
+47 SET PADFROMDTFM=$$PADFMTIME^SDESUTIL($PIECE(FROMDTFM,".",2))
+48 ;increment by 1 min
SET FRSTTMFMADJ=$PIECE($$FMADD^XLFDT(FROMDTFM,0,0,1,0),".",2)
+49 SET FRSTTMFMADJ=$$PADFMTIME^SDESUTIL(FRSTTMFMADJ)
+50 SET PADENDDTFM=$$PADFMTIME^SDESUTIL($PIECE(ENDDTFM,".",2))
+51 ;increment by 1 min
SET TOENDTMFMADJ=$PIECE($$FMADD^XLFDT(ENDDTFM,0,0,1,0),".",2)
+52 SET TOENDTMFMADJ=$$PADFMTIME^SDESUTIL(TOENDTMFMADJ)
+53 ; From Clinic
SET CLINID="F"
+54 ; Load From clinic segments from T node of the Hospital Location file
+55 DO SEGARRAY(SDORGCLIEN,FROMTIMESCALE,FROMDTFM,CLINBEGFROM,CLINID)
+56 if POP
QUIT
+57 ; Determine the evaluation start time
+58 SET SDSEGSTTIM=$ORDER(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+FRSTTMFMADJ),-1)
+59 ; Would we ever have an appt prior to the defined clinic start time???
+60 IF SDSEGSTTIM=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot begin time in originating clinic for evaluation")
QUIT
+61 ; Appt start time = segment start time
+62 IF +PADFROMDTFM=SDSEGSTTIM
SET SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
+63 ; Appt starts within the segment. Segment 8-8:30 Appt starts at 8:15
+64 IF +PADFROMDTFM>SDSEGSTTIM
IF (+PADFROMDTFM<SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM))
SET SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=SDSEGSTTIM
+65 ; Appt starts after the segment ends
+66 IF +PADFROMDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGSTTIM)
SET SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE")=+PADFROMDTFM
+67 ; Determine the evaluation end time
+68 SET SDSEGENDTIM=$ORDER(SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",+TOENDTMFMADJ),-1)
+69 IF SDSEGENDTIM=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Can't find slot end time in originating clinic for evaluation")
QUIT
+70 ; Appt end time fall within the segment
+71 IF +PADENDDTFM>SDSEGENDTIM
IF +PADENDDTFM<=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
SET $PIECE(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
+72 ; Appt end time > Segment end time
+73 IF +PADENDDTFM>=+SDSEGMENTS(SDORGCLIEN,CLINID,"SCHEDULE",SDSEGENDTIM)
SET $PIECE(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
+74 ; Appt end time = Segment end time
+75 IF +PADENDDTFM=SDSEGENDTIM
SET $PIECE(SDSEGMENTS(SDORGCLIEN,CLINID,"EVALUATE"),U,2)=+PADENDDTFM
+76 QUIT
+77 ;
SEGARRAY(CLIEN,TIMESCALE,FROMDTFM,CLINBEG,CLINID) ; Create local array to hold segments for validation comparisons
+1 NEW PATRNIEN,SDDOW,SDINDX,SDENDTIME,SDSLDATA,STOP,TINDX,I
+2 SET PATRNIEN=$PIECE(FROMDTFM,".",1)
+3 IF '$DATA(^SC(CLIEN,"T",PATRNIEN,0))
Begin DoDot:1
+4 SET SDDOW=$$DOW^XLFDT(PATRNIEN,1)
+5 FOR
SET PATRNIEN=$ORDER(^SC(CLIEN,"T",PATRNIEN),-1)
if PATRNIEN=0
QUIT
if $$DOW^XLFDT(PATRNIEN,1)=SDDOW
QUIT
+6 IF PATRNIEN'>0
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Availability definition not found")
End DoDot:1
if PATRNIEN'>0
QUIT
+7 ; Loop to find start time definition
+8 SET SDINDX=0
+9 FOR
SET SDINDX=$ORDER(^SC(CLIEN,"T",PATRNIEN,2,SDINDX))
if 'SDINDX
QUIT
Begin DoDot:1
+10 SET SDSLDATA=^SC(CLIEN,"T",PATRNIEN,2,SDINDX,0)
+11 SET SDENDTIME=$$FMADD^XLFDT(DT_"."_$PIECE(SDSLDATA,U,1),,,TIMESCALE)
+12 SET SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+$PIECE(SDSLDATA,U,1))=+$$PADFMTIME^SDESUTIL($PIECE(SDENDTIME,".",2))_"^"_$PIECE(SDSLDATA,U,2)
End DoDot:1
+13 ; Check and build Teal area
+14 SET SDINDX=0
+15 SET SDINDX=$ORDER(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX))
+16 if SDINDX=CLINBEG
QUIT
+17 SET STOP=""
+18 FOR I=1:1
Begin DoDot:1
+19 SET TINDX=$$FMADD^XLFDT(DT_"."_$$PADLENGTH^SDESUTIL(SDINDX,"0",4,"F"),,,-TIMESCALE)
+20 IF $PIECE(TINDX,".",1)'=DT
SET STOP=1
QUIT
+21 IF $PIECE(TINDX,".",2)=24
Begin DoDot:2
+22 SET STOP=1
SET SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",0)=SDINDX_"^-"
End DoDot:2
QUIT
+23 SET TINDX=+$$PADFMTIME^SDESUTIL($PIECE(TINDX,".",2))
+24 IF +TINDX<=CLINBEG
SET STOP=1
SET TINDX=CLINBEG
+25 SET SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",+TINDX)=SDINDX_"^-"
+26 SET SDINDX=+TINDX
End DoDot:1
if STOP
QUIT
+27 QUIT
+28 ;
SLOTCOUNT ;
+1 ; Verifying that we don't have more than the max allowable slots defined for the period of time we are reviewing
+2 IF $$IDTIMESLOT^SDESBLKANDMOVE1(SDORGCLIEN,1,"F")
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"More than 1 appointment slot in Originating clinic")
if POP
QUIT
+3 QUIT
+4 ;
APPDEL ;Call APPDEL RPC to cancel the current appointment
+1 ;Input:
+2 ; SDECAPPTIEN [REQ] - IEN of appointment to cancel
+3 ;Assume:
+4 ; SDAPPT - Array of data returned by the RPC
+5 ;Output:
+6 ; Any errors logged by call to APPDEL RPC
+7 NEW RET,TEXT,SDCANRSN,SDUSRNOTE,SDCANDT,SDAPTYP,SDF
+8 SET SDCANRSN=$$FIND1^DIC(409.2,,"B","BLOCK AND MOVE","","","SDERR")
+9 IF 'SDCANRSN
SET SDCANRSN=""
+10 SET SDF=""
+11 SET SDAPTYP=$GET(APPTARY(FN,SDECAPPTIENS,.22,"I"))
+12 ;I $P(SDAPTYP,";",2)="SD(403.5," S SDF=3
+13 DO APPDEL^SDEC08(.RET,APPTIEN,"C",SDCANRSN,,,,,SDF,,,$GET(EASTRCKNGNMBR))
+14 SET TEXT=$GET(^TMP("SDEC08",$JOB,"APPDEL",1))
+15 SET TEXT=$PIECE(TEXT,$CHAR(30))
+16 IF TEXT'=""
Begin DoDot:1
+17 SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,52,TEXT,"APPDEL^SDESAPPTSET")
End DoDot:1
+18 KILL ^TMP("SDEC08",$JOB)
+19 QUIT
+20 ;
APPADD(SDECAPPTIEN,SDECSTART,SDECLEN,SDECRES,SDECEND,FN,APPTARY,SDECAPPTIENS) ;entry point before calling APPADD^SDEC07
+1 ;Input:
+2 ; SDECAPPTIEN [REQ] - The IEN from SDEC APPOINTMENT File #409.84
+3 ; SDECSTART [REQ] - The internal format of Appointment Start Time
+4 ; SDECLEN [REQ] - Appointment length based on Time Scale from 409.831
+5 ; SDECRES [REQ] - The IEN from SDEC RESOURCE File #409.831.
+6 ; SDECEND [REQ] - Appointment end dt/tm in FM format
+7 ;
+8 ;Assume:
+9 ; APPTARY - Array of data from 409.84 for SDECAPPTIEN
+10 ; SDAPPT - Array of data returned by the RPC
+11 ;
+12 ;Output:
+13 ; Errors logged by call to APPADD or set NEWAPPTIEN
+14 ;
+15 NEW SDRET,SDDFN,SDECNOTE,SDECATID,SDECCR,SDDDT,SDAPTYP,SDCL,SDEL,SDECY
+16 KILL ^TMP("SDEC07",$JOB)
+17 ;Patient ID/DFN
SET SDDFN=$GET(APPTARY(FN,SDECAPPTIENS,.05,"I"))
+18 ;Clinic IEN pointer to HOSPITAL LOCATION file 44
SET SDCL=$PIECE($GET(^SDEC(409.831,+SDECRES,0)),U,4)
+19 ;S SDECEND=$$FMADD^XLFDT(SDECSTART,,,+SDECLEN) ;Appointment end time if SDECEND passed in as NULL
+20 ;Note
SET SDECNOTE=$GET(APPTARY(FN,SDECAPPTIENS,1,1))
+21 ;WALKIN - WALKIN flag y=YES; n=NO default to NO
SET SDECATID=$GET(APPTARY(FN,SDECAPPTIENS,.13,"E"))
+22 ;get the purpose of visit in the patient file if NULL in file 409.84
IF SDECATID=""!(SDECATID="NO")
SET SDECATID=$PIECE($GET(^DPT(SDDFN,"S",SDECSTART,0)),U,7)
+23 SET SDECATID=$SELECT(SDECATID="YES"!(SDECATID=4):"WALKIN",1:SDECATID)
+24 ;routing slip
SET SDECCR=$SELECT(SDECATID="WALKIN":0,1:1)
+25 ;desired date of appointment
SET SDDDT=$GET(APPTARY(FN,SDECAPPTIENS,.02,"I"))
+26 SET SDAPTYP=$$GET1^DIQ(FN,SDECAPPTIENS,.22,"E")
+27 SET SDAPTYP=$SELECT(SDAPTYP="APPT":"A",SDAPTYP="RECALL":"R",SDAPTYP="CONSULT":"C",SDAPTYP="EWL":"E",1:"")
+28 SET SDAPTYP=SDAPTYP_"|"_$PIECE($$GET1^DIQ(FN,SDECAPPTIENS,.22,"I"),";")
+29 ;Current Eligibility Code
SET SDEL=$PIECE($GET(^DPT(SDDFN,.36)),U,1)
+30 KILL SDECY
+31 ;ADD NEW APPOINTMENT
DO APPADD^SDEC07(.SDECY,$$FMTE^XLFDT(SDECSTART),$$FMTE^XLFDT(SDECEND),SDDFN,SDECRES,SDECLEN,$GET(SDECNOTE),SDECATID,,,SDPID,,,,,SDAPTYP,,,SDCL,,,,,OVB,,SDEL,$GET(EASTRCKNGNMBR))
+32 ;
+33 NEW CNTR,ERROR
+34 SET ERROR=""
+35 SET CNTR=$ORDER(^TMP("SDEC07",$JOB,0))
+36 IF CNTR
SET ERROR=$GET(^TMP("SDEC07",$JOB,CNTR))
+37 SET ERROR=$$CTRL^XMXUTIL1(ERROR)
+38 IF $PIECE(ERROR,"^",2)'=""
Begin DoDot:1
+39 SET POP=1
+40 DO ERRLOG^SDESJSON(.SDAPPT,52,$PIECE(ERROR,"^",2),"APPADD^SDESAPPTSET")
End DoDot:1
+41 IF '$TEST
Begin DoDot:1
+42 SET NEWAPPTIEN=$PIECE(ERROR,"^",1)
+43 IF $EXTRACT(SDAPTYP,1)="R"
IF $GET(APPTARY(FN,SDECAPPTIENS,.22,"I"))'=""
Begin DoDot:2
+44 NEW SDBM
+45 SET SDBM(409.84,NEWAPPTIEN_",",.22)=$GET(APPTARY(FN,SDECAPPTIENS,.22,"I"))
+46 DO UPDATE^DIE("","SDBM","SDERR")
End DoDot:2
End DoDot:1
+47 ;
+48 KILL ^TMP("SDEC07",$JOB)
+49 QUIT
