- 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 Feb 19, 2025@00:22:20 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