SDESBLKANDMOVE1 ;ALB/MGD/TAW - BLOCK AND MOVE CONT. ;Jan 21, 2022
;;5.3;Scheduling;**800,801,803,804**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
TOOVBCHECK(SDTOCLIEN,TODTFM,APPTARY,FN,SDECAPPTIENS,POP,SDAPPT,OVB) ; Check if new appt will be considered an overbook
N OBM,SDECWKIN,SDDFN,SDECATID
S SDECWKIN=""
S SDECATID=$G(APPTARY(FN,SDECAPPTIENS,.13,"E")) ;WALKIN - WALKIN flag y=YES; n=NO default to NO
S SDDFN=$G(APPTARY(FN,SDECAPPTIENS,.05,"I")) ;Patient ID/DFN
I SDECATID=""!(SDECATID="NO") S SDECATID=$P($G(^DPT(SDDFN,"S",TODTFM,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)
I SDECATID="WALKIN" S SDECWKIN=1
; check for max overbook and overbook keys. We assume yes if any check w/ user is needed.
S OBM=$$OBM1^SDEC57(SDTOCLIEN,TODTFM,0,,+SDECWKIN) ; Passing MRTC (3rd param) in as 0:False
I $E(OBM,1)=0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,"Overbook not allowed")
; OVB 1:should be flagged as Overbook 2:shouldn't be flagged as Overbook
S OVB=$S($E(OBM,1)=2:1,1:2)
Q
;
PREBLOCK(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SL,SDSEGMENTS) ;
; 1st call to block original slots
N SDINDX,SLOTS,MOVINGSTRT,SDECEND,EVALSTRT,EVALSTOP
S EVALSTRT=$P(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,1)
S EVALSTOP=$P(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,2)
S EVALSTRT=$$PADLENGTH^SDESUTIL(EVALSTRT,"0",4,"F")
; If orig appt occupied more than 1 slot in a variable length clinic, block the additional slots
S MOVINGSTRT=$P(FROMDTFM,".",1)_"."_EVALSTRT
F SLOTS=1:1 D Q:EVALSTOP<=+$$PADFMTIME^SDESUTIL($P(MOVINGSTRT,".",2))
.S SDECEND=$$FMADD^XLFDT(MOVINGSTRT,,,+FROMTIMESCALE)
.D BLOCK($P(MOVINGSTRT,".",1),$P(MOVINGSTRT,".",2),$P(SDECEND,".",2),SDORGCLIEN,SDDATA44SL,FROMTIMESCALE)
.S MOVINGSTRT=SDECEND
Q
;
BLOCK(SDSTDATE,SDSTTIME,SDENDTIME,SDORGCLIEN,SDDATA44SL,TIMESCALE) ; Logic copied from routine SDC
N A,CANREM,DA,DFN,DH,I,FR,NOAP,P,SD,SDCNT,SDDATA0,STARTDAY,SDDFR,SDHTO,SI,ST,TO,X,Y,%
S SC=SDORGCLIEN
; If the resource on the new IEN = resource on origial IEN, no need to block
; Determine timeslot equivalent
S %=$S(TIMESCALE=10:6,TIMESCALE=20:3,TIMESCALE=15:4,TIMESCALE=30:2,1:1)
S SI=$S(%="":4,%<3:4,%:%,1:4)
S %=$P(SDDATA44SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=%
S (CANREM,I)="BLOCK AND MOVE"
S SD=SDSTDATE
; If Start Time = midnight set to 0001 to pass TC
I $E(SDSTTIME,1,2)=24 S SDSTTIME="0001"
I +SDSTTIME=0 S SDSTTIME="0001"
S X=SDSTTIME_"0000",X=$E(X,1,4) D TC
S FR=Y,ST=%
; If End Time = midnight set to 2359 to pass TC
I $E(SDENDTIME,1,2)=24 S SDENDTIME=2359
I +SDENDTIME=0 S SDENDTIME=2359
S X=SDENDTIME_"0000",X=$E(X,1,4) D TC
S SDHTO=X,TO=Y,SDDFR=TO-FR
I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP
S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
S ^SC(SC,"S",FR,0)=FR,^SC(SC,"S",FR,"MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")")
D S S I=^SC(SC,"ST",SD,1),I=I_$J("",%-$L(I)),Y="" I $G(SDDFR)<100,$L(I)<77 S I=I_" " ;SD*5.3*758 - pad 4 empty spaces needed for blocks < 60 minutes
F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
S DH=0,^SC(SC,"ST",SD,1)=I,FR=FR-.0001 D C Q
S S ^SC(SC,"ST",SD,"CAN")=^SC(SC,"ST",SD,1) Q
;
C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) K SDX Q
N TDH,TMPD,DIE,DR,NODE,SDI
; SD*724 - Replace 'I' with 'SDI'
F SDI=0:0 S SDI=$O(^SC(SC,"S",FR,1,SDI)) Q:SDI'>0 D
.I '$D(^SC(SC,"S",FR,1,SDI,0)) I $D(^("C")) S J=FR,J2=SDI D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 delete corrupt node
.I '+$G(^SC(SC,"S",FR,1,SDI,0)) S J=FR,J2=SDI D DELETE^SDC1 K J,J2 Q ;SD*5.3*545 if DFN is missing delete record
.Q:$P(^SC(SC,"S",FR,1,SDI,0),"^",9)="C" ;SD*5.3*758 - Quit processing if appointment already canceled.
.S DFN=+^SC(SC,"S",FR,1,SDI,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
.D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,SDI,SDCNHDL)
.S $P(^SC(SC,"S",FR,1,SDI,0),"^",9)="C"
.S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0) ;added SD/523
.Q:$P(NODE,U,1)'=SC ;added SD/523
.S ^DPT("ASDCN",SC,FR,DFN)=""
.S SDSC=SC,SDTTM=FR,SDPL=SDI,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478
.I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE
.D SDEC^SDCNP0(DFN,FR,SC,"C","",$G(CANREM),SDTIME,DUZ) ;alb/sat 627
G C
;
MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
N SDV1
S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
; SD*724 - set SDPL with value from SDI
S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=SDI,SDRT="D" D RT^SDUTL
S DH=SDH K SDH D CK1,EVT
K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1
Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q
;
EVT ; -- separate tag if need to NEW vars
; -- cancel event
N FR,I,SDTIME,DH,SC
D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
Q
;
BUILDER ;Convert data to JSON
N JSONERR
S JSONERR=""
D ENCODE^SDESJSON(.SDAPPT,.RETURN,.JSONERR)
Q
;
TC N %DT S X=$$FMTE^XLFDT(SD)_"@"_X,%DT="T" D ^%DT I Y<0!(X["?") Q
S X=$E($P(Y_"0000",".",2),1,4),%=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2 I %<0 S Y=-1
I %>72 S Y=-1
Q
;
HASPATRN(SDTOCLIEN,SDDOW,TODTFM) ;find day template pattern
N SDE,SDTP
S SDTP=""
S SDTP=$G(^SC(SDTOCLIEN,"ST",$P(TODTFM,".",1),1))
S SDE=$O(^SC(SDTOCLIEN,"T"_SDDOW,TODTFM+1),-1)
; If never defined on a specific DOW, check continue indefintely node
I 'SDE S SDE=9999999
S SDTP=$G(^SC(SDTOCLIEN,"T"_SDDOW,SDE,1))
Q $S(SDTP="":0,1:1)
;
IDTIMESLOT(CLIEN,MAXSLOTS,CLINID) ;
; CLIEN = IEN of clinic
; MAXSLOTS = Maximum # of slots to check allowable
N SDINDX,SDINDXEND,POP
S POP=0
S SDINDX=$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,1)-.0001
S SDINDXEND=$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
F S SDINDX=$O(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX)) Q:'SDINDX!(SDINDX>=+SDINDXEND) D Q:POP
.I $P(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX),U,2)>MAXSLOTS S POP=1
Q POP
;
CHKAVAILABILITY(RES,CLIEN,APPTDTNET,CLINID,MOVE2DATE) ;Check the Clinic Resource and Appt Dt for slot availability
; RES - Clinic resource of the new appointment
; CLIEN - IEN of clinic being evaluated
; APPTDTNET - Appointment date/time in external format
; CLINID - F = From clinic, T = To clinic
; MOVE2DAT - The original appt date/tm or the new appt date/tm in FM format
;
N RET,TEXT,I,DATA,SLOTS,CNT,EVALSTRT,EVALSTOP,APPTSTRT,APPTEND,EAPPTDATA
S SLOTS="",CNT=0
S EVALSTRT=+SDSEGMENTS(CLIEN,CLINID,"EVALUATE")
S EVALSTOP=+$P(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
K ^TMP("SDEC57",$J)
D APPSLOTS^SDEC57(.RET,RES,APPTDTNET,APPTDTNET)
S TEXT=$G(^TMP("SDEC57",$J,"APPSLOTS",1))
I $P(TEXT,"^",1)=-1 D Q
.S POP=1 D ERRLOG^SDESJSON(.SDAPPT,52,$P(TEXT,"^",2))
I CLINID="T",TEXT="" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date") Q
;
;DATA = fm dt ^ fm time ^ ^# of slots
S I=0
F S I=$O(^TMP("SDEC57",$J,"APPSLOTS",I)) Q:I="" D Q:POP
.S DATA=^TMP("SDEC57",$J,"APPSLOTS",I)
.S DATA=$$CTRL^XMXUTIL1(DATA)
.I +$P(DATA,"^",2)<EVALSTRT Q
.I +$P(DATA,"^",2)>=EVALSTOP Q
.S SLOTS=$P(DATA,"^",4)
.Q:SLOTS="" ; Appears APPSLOTS^SDEC57 puts a "" to represent the period after the end of clinic availability
.I CLINID="F" D ; ### check order of next 2 lines
..I SLOTS'="0",SLOTS'="1",SLOTS'="*" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked") Q
..;If orig appt slot is overbook, no B&M
..I +$P(DATA,U,2)=+$$PADFMTIME^SDESUTIL($P(FROMDTFM,".",2)) D
...I SLOTS'=0,SLOTS'="*" S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked")
.I CLINID="T" D Q:POP
..I SLOTS'>0 S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic has no availability") Q
; Check for existing appts in clinic based on Start/End time of appt
Q:POP
N TIME,IEN
S TIME=$$PADLENGTH^SDESUTIL(EVALSTOP,"0",4,"F")
S TIME=$P(MOVE2DATE,".",1)_"."_TIME
F S TIME=$O(^SDEC(409.84,"ARSRC",RES,+TIME),-1) Q:TIME'[$P(MOVE2DATE,".",1) D Q:POP
.S IEN=""
.F S IEN=$O(^SDEC(409.84,"ARSRC",RES,TIME,IEN)) Q:'IEN D Q:POP
..Q:IEN=APPTIEN
..S EAPPTDATA=$G(^SDEC(409.84,IEN,0))
..Q:EAPPTDATA=""
..; Skip cancelled appts
..I $P(EAPPTDATA,U,17)'=""&("C^CA^PC^PCA^"["^"_$P(EAPPTDATA,U,17)_"^") Q
..S APPTSTRT=$E($P($P(EAPPTDATA,"^",1),".",2)_"0000",1,4)
..S APPTEND=$E($P($P(EAPPTDATA,"^",2),".",2)_"0000",1,4)
..; The Appt start time > EVALUATE start time
..I APPTSTRT>EVALSTRT S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict") Q
..; If any existing appt has a partial overlap within our EVALUATE Start/End - can't B&M
..I APPTEND>EVALSTRT,APPTEND<EVALSTOP S POP=1 D ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict") Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESBLKANDMOVE1 9707 printed Sep 23, 2025@20:32:40 Page 2
SDESBLKANDMOVE1 ;ALB/MGD/TAW - BLOCK AND MOVE CONT. ;Jan 21, 2022
+1 ;;5.3;Scheduling;**800,801,803,804**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
TOOVBCHECK(SDTOCLIEN,TODTFM,APPTARY,FN,SDECAPPTIENS,POP,SDAPPT,OVB) ; Check if new appt will be considered an overbook
+1 NEW OBM,SDECWKIN,SDDFN,SDECATID
+2 SET SDECWKIN=""
+3 ;WALKIN - WALKIN flag y=YES; n=NO default to NO
SET SDECATID=$GET(APPTARY(FN,SDECAPPTIENS,.13,"E"))
+4 ;Patient ID/DFN
SET SDDFN=$GET(APPTARY(FN,SDECAPPTIENS,.05,"I"))
+5 ;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",TODTFM,0)),U,7)
+6 SET SDECATID=$SELECT(SDECATID="YES"!(SDECATID=4):"WALKIN",1:SDECATID)
+7 IF SDECATID="WALKIN"
SET SDECWKIN=1
+8 ; check for max overbook and overbook keys. We assume yes if any check w/ user is needed.
+9 ; Passing MRTC (3rd param) in as 0:False
SET OBM=$$OBM1^SDEC57(SDTOCLIEN,TODTFM,0,,+SDECWKIN)
+10 IF $EXTRACT(OBM,1)=0
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,52,"Overbook not allowed")
+11 ; OVB 1:should be flagged as Overbook 2:shouldn't be flagged as Overbook
+12 SET OVB=$SELECT($EXTRACT(OBM,1)=2:1,1:2)
+13 QUIT
+14 ;
PREBLOCK(FROMDTFM,FROMTIMESCALE,FROMRES,SDORGCLIEN,SDDATA44SL,SDSEGMENTS) ;
+1 ; 1st call to block original slots
+2 NEW SDINDX,SLOTS,MOVINGSTRT,SDECEND,EVALSTRT,EVALSTOP
+3 SET EVALSTRT=$PIECE(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,1)
+4 SET EVALSTOP=$PIECE(SDSEGMENTS(SDORGCLIEN,"F","EVALUATE"),U,2)
+5 SET EVALSTRT=$$PADLENGTH^SDESUTIL(EVALSTRT,"0",4,"F")
+6 ; If orig appt occupied more than 1 slot in a variable length clinic, block the additional slots
+7 SET MOVINGSTRT=$PIECE(FROMDTFM,".",1)_"."_EVALSTRT
+8 FOR SLOTS=1:1
Begin DoDot:1
+9 SET SDECEND=$$FMADD^XLFDT(MOVINGSTRT,,,+FROMTIMESCALE)
+10 DO BLOCK($PIECE(MOVINGSTRT,".",1),$PIECE(MOVINGSTRT,".",2),$PIECE(SDECEND,".",2),SDORGCLIEN,SDDATA44SL,FROMTIMESCALE)
+11 SET MOVINGSTRT=SDECEND
End DoDot:1
if EVALSTOP<=+$$PADFMTIME^SDESUTIL($PIECE(MOVINGSTRT,".",2))
QUIT
+12 QUIT
+13 ;
BLOCK(SDSTDATE,SDSTTIME,SDENDTIME,SDORGCLIEN,SDDATA44SL,TIMESCALE) ; Logic copied from routine SDC
+1 NEW A,CANREM,DA,DFN,DH,I,FR,NOAP,P,SD,SDCNT,SDDATA0,STARTDAY,SDDFR,SDHTO,SI,ST,TO,X,Y,%
+2 SET SC=SDORGCLIEN
+3 ; If the resource on the new IEN = resource on origial IEN, no need to block
+4 ; Determine timeslot equivalent
+5 SET %=$SELECT(TIMESCALE=10:6,TIMESCALE=20:3,TIMESCALE=15:4,TIMESCALE=30:2,1:1)
+6 SET SI=$SELECT(%="":4,%<3:4,%:%,1:4)
+7 SET %=$PIECE(SDDATA44SL,U,3)
SET STARTDAY=$SELECT($LENGTH(%):%,1:8)
DO NOW^%DTC
SET SDTIME=%
+8 SET (CANREM,I)="BLOCK AND MOVE"
+9 SET SD=SDSTDATE
+10 ; If Start Time = midnight set to 0001 to pass TC
+11 IF $EXTRACT(SDSTTIME,1,2)=24
SET SDSTTIME="0001"
+12 IF +SDSTTIME=0
SET SDSTTIME="0001"
+13 SET X=SDSTTIME_"0000"
SET X=$EXTRACT(X,1,4)
DO TC
+14 SET FR=Y
SET ST=%
+15 ; If End Time = midnight set to 2359 to pass TC
+16 IF $EXTRACT(SDENDTIME,1,2)=24
SET SDENDTIME=2359
+17 IF +SDENDTIME=0
SET SDENDTIME=2359
+18 SET X=SDENDTIME_"0000"
SET X=$EXTRACT(X,1,4)
DO TC
+19 SET SDHTO=X
SET TO=Y
SET SDDFR=TO-FR
+20 IF '$DATA(^SC(SC,"SDCAN",0))
SET ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1"
GOTO SKIP
+21 SET A=^SC(SC,"SDCAN",0)
SET SDCNT=$PIECE(A,"^",4)
SET ^SC(SC,"SDCAN",0)=$PIECE(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
SKIP SET ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
+1 SET NOAP=$SELECT($ORDER(^SC(SC,"S",(FR-.0001)))'>0:1,$ORDER(^SC(SC,"S",(FR-.0001)))>TO:1,1:0)
IF 'NOAP
SET NOAP=$SELECT($ORDER(^SC(SC,"S",+$ORDER(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
+2 SET ^SC(SC,"S",FR,0)=FR
SET ^SC(SC,"S",FR,"MES")="CANCELLED UNTIL "_X_$SELECT(I?.P:"",1:" ("_I_")")
+3 ;SD*5.3*758 - pad 4 empty spaces needed for blocks < 60 minutes
DO S
SET I=^SC(SC,"ST",SD,1)
SET I=I_$JUSTIFY("",%-$LENGTH(I))
SET Y=""
IF $GET(SDDFR)<100
IF $LENGTH(I)<77
SET I=I_" "
+4 FOR X=0:2:%
SET DH=$EXTRACT(I,X+SI+SI)
SET P=$SELECT(X<ST:DH_$EXTRACT(I,X+1+SI+SI),X=%:$SELECT(Y="[":Y,1:DH)_$EXTRACT(I,X+1+SI+SI),1:$SELECT(Y="["&(X=ST):"]",1:"X")_"X")
SET Y=$SELECT(DH="]":"",DH="[":DH,1:Y)
SET I=$EXTRACT(I,1,X-1+SI+SI)_P_$EXTRACT(I,X+2+SI+SI,999)
+5 if '$FIND(I,"[")
SET I5=$FIND(I,"X")
SET I=$EXTRACT(I,1,(I5-2))_"["_$EXTRACT(I,I5,999)
KILL I5
+6 SET DH=0
SET ^SC(SC,"ST",SD,1)=I
SET FR=FR-.0001
DO C
QUIT
S SET ^SC(SC,"ST",SD,"CAN")=^SC(SC,"ST",SD,1)
QUIT
+1 ;
C SET FR=$ORDER(^SC(SC,"S",FR))
IF FR<1!(FR'<TO)
KILL SDX
QUIT
+1 NEW TDH,TMPD,DIE,DR,NODE,SDI
+2 ; SD*724 - Replace 'I' with 'SDI'
+3 FOR SDI=0:0
SET SDI=$ORDER(^SC(SC,"S",FR,1,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+4 ;SD*5.3*545 delete corrupt node
IF '$DATA(^SC(SC,"S",FR,1,SDI,0))
IF $DATA(^("C"))
SET J=FR
SET J2=SDI
DO DELETE^SDC1
KILL J,J2
QUIT
+5 ;SD*5.3*545 if DFN is missing delete record
IF '+$GET(^SC(SC,"S",FR,1,SDI,0))
SET J=FR
SET J2=SDI
DO DELETE^SDC1
KILL J,J2
QUIT
+6 ;SD*5.3*758 - Quit processing if appointment already canceled.
if $PIECE(^SC(SC,"S",FR,1,SDI,0),"^",9)="C"
QUIT
+7 SET DFN=+^SC(SC,"S",FR,1,SDI,0)
SET SDCNHDL=$$HANDLE^SDAMEVT(1)
+8 DO BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,SDI,SDCNHDL)
+9 SET $PIECE(^SC(SC,"S",FR,1,SDI,0),"^",9)="C"
+10 ;added SD/523
if $DATA(^DPT(DFN,"S",FR,0))
SET NODE=^(0)
+11 ;added SD/523
if $PIECE(NODE,U,1)'=SC
QUIT
+12 SET ^DPT("ASDCN",SC,FR,DFN)=""
+13 ;SD/478
SET SDSC=SC
SET SDTTM=FR
SET SDPL=SDI
SET TDH=DH
SET TMPD=CANREM
DO CANCEL^SDCNSLT
SET DH=TDH
+14 IF $DATA(^DPT(DFN,"S",FR,0))
IF $PIECE(^(0),"^",2)'["C"
SET $PIECE(^(0),"^",2)="C"
SET $PIECE(^(0),"^",12)=DUZ
SET $PIECE(^(0),"^",14)=SDTIME
SET DH=DH+1
SET TDH=DH
SET DIE="^DPT(DFN,"_"""S"""_","
SET DR="17///^S X=CANREM"
SET DA=FR
DO ^DIE
SET DH=TDH
DO MORE
+15 ;alb/sat 627
DO SDEC^SDCNP0(DFN,FR,SC,"C","",$GET(CANREM),SDTIME,DUZ)
End DoDot:1
+16 GOTO C
+17 ;
MORE IF $DATA(^SC("ARAD",SC,FR,DFN))
SET ^(DFN)="N"
+1 NEW SDV1
+2 SET SDIV=$SELECT($PIECE(^SC(SC,0),"^",15)]"":$PIECE(^(0),"^",15),1:" 1")
SET SDV1=$SELECT(SDIV:SDIV,1:+$ORDER(^DG(40.8,0)))
IF $DATA(^DPT("ASDPSD","C",SDIV,SC,FR,DFN))
KILL ^(DFN)
+3 ; SD*724 - set SDPL with value from SDI
+4 SET SDH=DH
SET SDTTM=FR
SET SDSC=SC
SET SDPL=SDI
SET SDRT="D"
DO RT^SDUTL
+5 SET DH=SDH
KILL SDH
DO CK1
DO EVT
+6 KILL SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX
QUIT
CK1 SET SDX=0
FOR SD1=FR\1:0
SET SD1=$ORDER(^DPT(DFN,"S",SD1))
if 'SD1!((SD1\1)'=(FR\1))
QUIT
IF $PIECE(^(SD1,0),"^",2)'["C"
IF $PIECE(^(0),"^",2)'["N"
SET SDX=1
QUIT
+1 if SDX
QUIT
FOR SD1=2,4
IF $DATA(^SC("AAS",SD1,FR\1,DFN))
SET SDX=1
QUIT
+2 if SDX
QUIT
IF $DATA(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0))
SET SDX=1
+3 if SDX
QUIT
KILL ^DPT("ASDPSD","B",SDIV,FR\1,DFN)
QUIT
+4 ;
EVT ; -- separate tag if need to NEW vars
+1 ; -- cancel event
+2 NEW FR,I,SDTIME,DH,SC
+3 DO CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL)
KILL SDATA,SDCNHDL
+4 QUIT
+5 ;
BUILDER ;Convert data to JSON
+1 NEW JSONERR
+2 SET JSONERR=""
+3 DO ENCODE^SDESJSON(.SDAPPT,.RETURN,.JSONERR)
+4 QUIT
+5 ;
TC NEW %DT
SET X=$$FMTE^XLFDT(SD)_"@"_X
SET %DT="T"
DO ^%DT
IF Y<0!(X["?")
QUIT
+1 SET X=$EXTRACT($PIECE(Y_"0000",".",2),1,4)
SET %=$EXTRACT(X,3,4)
SET %=X\100-STARTDAY*SI+(%*SI\60)*2
IF %<0
SET Y=-1
+2 IF %>72
SET Y=-1
+3 QUIT
+4 ;
HASPATRN(SDTOCLIEN,SDDOW,TODTFM) ;find day template pattern
+1 NEW SDE,SDTP
+2 SET SDTP=""
+3 SET SDTP=$GET(^SC(SDTOCLIEN,"ST",$PIECE(TODTFM,".",1),1))
+4 SET SDE=$ORDER(^SC(SDTOCLIEN,"T"_SDDOW,TODTFM+1),-1)
+5 ; If never defined on a specific DOW, check continue indefintely node
+6 IF 'SDE
SET SDE=9999999
+7 SET SDTP=$GET(^SC(SDTOCLIEN,"T"_SDDOW,SDE,1))
+8 QUIT $SELECT(SDTP="":0,1:1)
+9 ;
IDTIMESLOT(CLIEN,MAXSLOTS,CLINID) ;
+1 ; CLIEN = IEN of clinic
+2 ; MAXSLOTS = Maximum # of slots to check allowable
+3 NEW SDINDX,SDINDXEND,POP
+4 SET POP=0
+5 SET SDINDX=$PIECE(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,1)-.0001
+6 SET SDINDXEND=$PIECE(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
+7 FOR
SET SDINDX=$ORDER(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX))
if 'SDINDX!(SDINDX>=+SDINDXEND)
QUIT
Begin DoDot:1
+8 IF $PIECE(SDSEGMENTS(CLIEN,CLINID,"SCHEDULE",SDINDX),U,2)>MAXSLOTS
SET POP=1
End DoDot:1
if POP
QUIT
+9 QUIT POP
+10 ;
CHKAVAILABILITY(RES,CLIEN,APPTDTNET,CLINID,MOVE2DATE) ;Check the Clinic Resource and Appt Dt for slot availability
+1 ; RES - Clinic resource of the new appointment
+2 ; CLIEN - IEN of clinic being evaluated
+3 ; APPTDTNET - Appointment date/time in external format
+4 ; CLINID - F = From clinic, T = To clinic
+5 ; MOVE2DAT - The original appt date/tm or the new appt date/tm in FM format
+6 ;
+7 NEW RET,TEXT,I,DATA,SLOTS,CNT,EVALSTRT,EVALSTOP,APPTSTRT,APPTEND,EAPPTDATA
+8 SET SLOTS=""
SET CNT=0
+9 SET EVALSTRT=+SDSEGMENTS(CLIEN,CLINID,"EVALUATE")
+10 SET EVALSTOP=+$PIECE(SDSEGMENTS(CLIEN,CLINID,"EVALUATE"),U,2)
+11 KILL ^TMP("SDEC57",$JOB)
+12 DO APPSLOTS^SDEC57(.RET,RES,APPTDTNET,APPTDTNET)
+13 SET TEXT=$GET(^TMP("SDEC57",$JOB,"APPSLOTS",1))
+14 IF $PIECE(TEXT,"^",1)=-1
Begin DoDot:1
+15 SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,52,$PIECE(TEXT,"^",2))
End DoDot:1
QUIT
+16 IF CLINID="T"
IF TEXT=""
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic is not open on this date")
QUIT
+17 ;
+18 ;DATA = fm dt ^ fm time ^ ^# of slots
+19 SET I=0
+20 FOR
SET I=$ORDER(^TMP("SDEC57",$JOB,"APPSLOTS",I))
if I=""
QUIT
Begin DoDot:1
+21 SET DATA=^TMP("SDEC57",$JOB,"APPSLOTS",I)
+22 SET DATA=$$CTRL^XMXUTIL1(DATA)
+23 IF +$PIECE(DATA,"^",2)<EVALSTRT
QUIT
+24 IF +$PIECE(DATA,"^",2)>=EVALSTOP
QUIT
+25 SET SLOTS=$PIECE(DATA,"^",4)
+26 ; Appears APPSLOTS^SDEC57 puts a "" to represent the period after the end of clinic availability
if SLOTS=""
QUIT
+27 ; ### check order of next 2 lines
IF CLINID="F"
Begin DoDot:2
+28 IF SLOTS'="0"
IF SLOTS'="1"
IF SLOTS'="*"
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked")
QUIT
+29 ;If orig appt slot is overbook, no B&M
+30 IF +$PIECE(DATA,U,2)=+$$PADFMTIME^SDESUTIL($PIECE(FROMDTFM,".",2))
Begin DoDot:3
+31 IF SLOTS'=0
IF SLOTS'="*"
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"appointment currently overbooked")
End DoDot:3
End DoDot:2
+32 IF CLINID="T"
Begin DoDot:2
+33 IF SLOTS'>0
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Destination clinic has no availability")
QUIT
End DoDot:2
if POP
QUIT
End DoDot:1
if POP
QUIT
+34 ; Check for existing appts in clinic based on Start/End time of appt
+35 if POP
QUIT
+36 NEW TIME,IEN
+37 SET TIME=$$PADLENGTH^SDESUTIL(EVALSTOP,"0",4,"F")
+38 SET TIME=$PIECE(MOVE2DATE,".",1)_"."_TIME
+39 FOR
SET TIME=$ORDER(^SDEC(409.84,"ARSRC",RES,+TIME),-1)
if TIME'[$PIECE(MOVE2DATE,".",1)
QUIT
Begin DoDot:1
+40 SET IEN=""
+41 FOR
SET IEN=$ORDER(^SDEC(409.84,"ARSRC",RES,TIME,IEN))
if 'IEN
QUIT
Begin DoDot:2
+42 if IEN=APPTIEN
QUIT
+43 SET EAPPTDATA=$GET(^SDEC(409.84,IEN,0))
+44 if EAPPTDATA=""
QUIT
+45 ; Skip cancelled appts
+46 IF $PIECE(EAPPTDATA,U,17)'=""&("C^CA^PC^PCA^"["^"_$PIECE(EAPPTDATA,U,17)_"^")
QUIT
+47 SET APPTSTRT=$EXTRACT($PIECE($PIECE(EAPPTDATA,"^",1),".",2)_"0000",1,4)
+48 SET APPTEND=$EXTRACT($PIECE($PIECE(EAPPTDATA,"^",2),".",2)_"0000",1,4)
+49 ; The Appt start time > EVALUATE start time
+50 IF APPTSTRT>EVALSTRT
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict")
QUIT
+51 ; If any existing appt has a partial overlap within our EVALUATE Start/End - can't B&M
+52 IF APPTEND>EVALSTRT
IF APPTEND<EVALSTOP
SET POP=1
DO ERRLOG^SDESJSON(.SDAPPT,124,"Existing scheduling conflict")
QUIT
End DoDot:2
if POP
QUIT
End DoDot:1
if POP
QUIT
+53 QUIT
