SDM1 ;SF/GFT - MAKE APPOINTMENT ; May 10, 2021@19:53:47
;;5.3;Scheduling;**32,167,168,80,223,263,273,408,327,478,490,446,547,611,674,739,753,769,775**;Aug 13, 1993;Build 5
1 Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC ;SD*5.3*753 - Remove unlock all
S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
S X2=SDEDT D C^%DTC S SDEDT=X D WRT
I $D(^SC(SC,"SI")),$O(^("SI",0))>0 W !,*7,?8,"**** SPECIAL INSTRUCTIONS ****",! S %I=0 F %=0:1 S %I=$O(^SC(SC,"SI",%I)) Q:%I'>0 W ^(%I,0) W:% ! I '%,$O(^SC(SC,"SI",%I))>0 S POP=0 D SPIN Q:POP
I $D(SDINA),SDINA>DT D IN W !,?8,@SDMSG K SDMSG
G:SDMM RDTY^SDMM
;
ADT S:'$D(SDW) SDW=""
S SDSOH=$S('$D(^SC(SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1),CCX=""
S SDONCE=$G(SDONCE)+1 ;Prevent repetitive iteration
; Section introduced in 446.
; Removed EWL Decommisson - SD*5.3*769
;N SDDATE1,SDQT,Y ; Do not allow progress if there is no availability > 120 days after the desired date.
;S SDDATE1=$S($G(SDDATE)="":DT,1:SDDATE)
;S Y="" D Q:Y="^"
;.F Q:Y="^"!$$WLCL120^SDM2A(SC,SDDATE1) D
;..;S Y=$$WLCLASK^SDM2A() Q:Y="^" ; Y=0: New date, Y=1: place on EWL, Y="^": quit
;..I Y=0 D Q
;...N SDMAX,SDDMAX
;...S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
;...S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
;...S Y=$$DDATE^SDM0(.SDDATE,"0^0",.SDMAX) Q:'Y ; Y=0: "^" entered, Y=1: date entered
;...D D^SDM0
;...S SDDATE1=SDDATE
;...Q
;..D WL^SDM2A(SC)
;..S Y="^" ; quit
;..Q
;.Q
;
S X=$S(SDONCE<2:$G(SDSDATE),1:"") ;Use default date/time if specified as 'desired date'
I 'X R !,"DATE/TIME: ",X:DTIME Q:X="^" ;!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446 - Removed EWl Decom, SD*5.3*769
;I X="" D WL(SC) Q ;sd/446 - Removed EWl Decom, SD*5.3*769
G:X="M"!(X="m") MORDIS^SDM0
I X="D"!(X="d") S X=$$REDDT() G:X>0 MORD2^SDM0 S X="" W " ??",! G ADT
I X?1"?".E D G ADT
.W !,"Enter a date/time for the appointment - PAST dates must include the YEAR" ;SD*547 added note about past dates
.W:$D(SD) " or a space to choose the same date/time as the patient you have just previously scheduled into this clinic"
.W ".",!,"You may also select 'M' to display the next month's availability or"
.W !,"'D' to specify an earlier or later date to begin the availability display."
I X=" ",$D(SD),SD S Y=SD D AT^SDUTL W Y S Y=SD G OVR
I $E($P(X,"@",2),1,4)?1.4"0" K %DT S X=$P(X,"@"),X=$S($L(X):X,1:"T"),%DT="XF" D ^%DT G ADT:Y'>0 S X1=Y,X2=-1 D C^%DTC S X=X_.24
K %DT S %DT="TXEF" D ^%DT
;SD*5.3*408 verify that day hasn't been canceled via "SET UP A CLINIC"
I $G(^SC(+SC,"ST",$P(Y,"."),1))'="",^SC(+SC,"ST",$P(Y,"."),1)'["[" D G ADT
.W !,"There is no availability for this date/time.",!
I $P(Y,".",2)=24 S X1=$P(Y,"."),X2=1 D C^%DTC S Y=X_".000001"
OVR I $D(^HOLIDAY($P(Y,"."),0)),'SDSOH W *7,?50,$P(^(0),U,2),"??" K SDSDATE G ADT
I $D(SDINA),$P(Y,".")'<SDINA,$S('$D(SDRE):1,SDRE>$P(Y,".")!('SDRE):1,1:0) D IN W !,*7,@SDMSG K SDMSG K SDSDATE G ADT
I Y#1=0 K SDSDATE G 1
I $P(Y,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 K SDSDATE G ADT
;
EN1 S (TMPD,X,SD)=Y,SM=0 D DOW ;SD/478
F S=$P(SD,"."):0 S S=+$O(^DPT(DFN,"S",S)) Q:$P(S,".")-($P(SD,".")) S I=+^(S,0) G ^SDM2:$P(^(0),U,2)'["C"
;
PRECAN I $D(^DPT(DFN,"S",SD,0)),$P(^(0),U,2)["P" S %=1 W !,"THIS TIME WAS PREVIOUSLY CANCELLED BY THE PATIENT",!,"ARE YOU SURE THAT YOU WANT TO PROCEED" D YN^DICN W:'% !,"ANSWER WITH (Y)ES OR (N)O" I (%-1) K SDSDATE G ADT
W !
;SD*5.3*490 - AVCHK/AVCHK1 to check against pat DOB and clinic avail dt
S S POP=0 D AVCHK G:POP 1
S POP=0 D AVCHK1 G:POP 1
N SDBEGDT,DY ;New variables for Date check - SD*5.3*674
;SD*5.3*547 if selected date is prior to the date the day of the week was added to clinic, do not set the date into availability pattern
I '$D(^SC(SC,"ST",$P(SD,"."),1)) D
.S XDT=X,POP=0
.D DOWCHK^SDM0
.S SDBEGDT=$$BEGDAT^SDM0($P(SD,"."),Y) ;Check if begin date of indefinite schedule is prior to appointment date - SD*5.3*674
.K XDT
.K:POP SDSDATE
G:POP 1
I $G(SDBEGDT) S DY=$$DOW^XLFDT($P(SD,".")) D DWWRT^SDM0 G 1 ;Indefinite schedule is prior to appointment date - SD*5.3*674
K POP
I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) G XW:SS'>0,XW:^(SS,1)="" S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
;
LEN I $P(SL,U,2)]"" W !,"LENGTH OF APPOINTMENT (IN MINUTES): ",+SL,"// " R S:DTIME I S]"" G:$L(S)>3 LEN Q:U[S S POP=0 D L G LEN:POP,S:S\5*5'=S,S:S>360,S:S<5 S SL=S_U_$P(SL,U,2,99)
;
SC S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) G:SDLOCK>9 LOCK
L +^SC(SC,"ST",$P(SD,"."),1):$S($G(DILOCKTM)>0:DILOCKTM,1:5) G:'$T SC ;SD*53.*547 new required lock functionality
S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
G X:(I<1!'$F(S,"["))&(S'["CAN")
I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
;
SP I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
N SDSLSV ;*775
S SDNOT=1 ;SD*5.3*490 naked Do added below
;SD*5.3*739 adds check for SDCAN node as CAN node is deleted when clinic is remapped
;SD*5.3*753 allows unlimited overbooks on nonscheduled availabilities in SDMULTIBOOK option, as is allowed in VSE and single appointment Vista
F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$S("{}&%?#"[ST:ST,1:$E(STR,$F(STR,ST)-2)) G C:S["CAN"!(ST="X"&(($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))!($O(^SC(+SC,"SDCAN",$P(SD,".")))<($P(SD,".")+1)))),X:Y="" D
.S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) D S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
..Q:ST'=""
..Q:+SL'>+^SC(SC,"SL")
..S ST=" "
..Q
;SD*5.3*775 save SL to a namespaced variable
Q:SDMM S SDSLSV=SL G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
;
E G:'$D(^XUSEC("SDOB",DUZ)) NOOB
S %=2 W *7,!,$E($T(@SM),5,99),"...OK" D YN^DICN
I '% W !,"RESPOND YES OR NO" G E
S SM=9 G SC:'(%-1) K SDSDATE G 1
;
LOCK Q:SDMM W !,*7,"ANOTHER USER HAS LOCKED THIS DATE - TRY AGAIN LATER" Q
;
6 ;;OVERBOOK!
7 ;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD!
C S POP=1 W !,*7,"CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!",!
Q:SDMM K SDSDATE G 1
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
DOW S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
F %=%:-1:281 S Y=%#4=1+1+Y
S Y=$E(X,6,7)+Y#7 Q
;
X I SDMM S POP=1 Q
G:I<1 XW
S:Y'?1NL&(SM<6) SM=6
G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
XW W *7," WHEN??" K SDSDATE G 1
;
AVCHK ;added SD*5.3*490
I '$D(VADM) Q:'DFN S VADM(3)=$P(^DPT(DFN,0),U,3)
Q:$P(X,".",1)=$P(VADM(3),U,1)
I $P(X,".",1)<$P(VADM(3),U,1) W *7,!!,"That date is prior to the patient's date of birth.",!! S POP=1 K SDSDATE Q
Q
;
AVCHK1 ;added SD*5.3*490
S AVDT=0,AVDT=$O(^SC(+SC,"T",AVDT)) Q:'AVDT
I $P(X,".",1)<AVDT W *7,!!,"That date is prior to the clinic's availability date.",!! S POP=1 K SDSDATE,AVDT Q
Q
;
NOOB W !,"NO OPEN SLOTS THEN",*7 K SDSDATE G 1
;
WRT W !,+SL," MINUTE APPOINTMENTS "
W $S($P(SL,U,2)["V":"(VARIABLE LENGTH)",1:"") Q
;
L S SDSL=$S($P(SL,"^",6)]"":60/$P(SL,"^",6),1:"") Q:'SDSL
I S\(SDSL)*(SDSL)'=S W *7,!,"Appt. length must = or be a multiple of the increment minutes per hour (",SDSL,")",! S POP=1
Q
;
IN S SDHY=$S($D(Y):Y,1:""),Y=SDINA D DTS^SDUTL S Y1=Y,Y=SDRE
D:Y DTS^SDUTL
S SDMSG="""*** Note: Clinic is scheduled to be inactivated on "","_""""_Y1_""""_$S(SDRE:",!,?10,"_""" and reactivated on "","_""""_Y_"""",1:""),Y=SDHY K Y1,SDHY
Q
;
SPIN W !,"There are more special instructions. Do you want to display them"
S %=2 D YN^DICN
I '% W !,"Enter Y to see the remaining special instructions, or N if you don't wish to see them" G SPIN
I (%-1) S POP=1 Q
W !,^SC(SC,"SI",%I,0),! Q
;
REDDT() ;Prompt for availability redisplay date
N %DT,X,Y
S %DT="AEX"
S %DT("A")="DATE TO BEGIN THE RE-DISPLAY OF CLINIC AVAILABILITY: "
W ! D ^%DT
Q Y
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
Q ;SD*5.3*769 - EWL DECOM
Q:$G(SC)'>0
I '$D(^SC(SC)) Q
I $D(SC) S SDWLFLG=0 D
.I $D(^SDWL(409.32,"B",+SC)) S SDWLFLG=1
.; SD*5.3*611 DO command removed and second level dot structure removed
.I 'SDWLFLG S SDWLDSS=$P($G(^SC(+SC,0)),U,7) I $D(^SDWL(409.31,"B",SDWLDSS)) S SDWLFLG=2
.I SDWLFLG=1 S SDWLSC=$O(^SDWL(409.32,"B",+SC,0)) I $P(^SDWL(409.32,SDWLSC,0),U,4) S SDWLFLG=0
.I SDWLFLG=2 S SDWLDS=$O(^SDWL(409.31,"E",DUZ(2),0)) I $D(^SDWL(409.31,SDWLDSS,"I",+SDWLDS,0)),$P(^(0),U,4) S SDWLFLG=0
.I SDWLFLG D
..K SDWLSC,SDWLDSS,SDWLDS,SDWLFLG
..S SDWLOPT=1,SDWLERR=0 D OPT^SDWLE D EN^SDWLKIL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDM1 8665 printed Dec 13, 2024@02:58:17 Page 2
SDM1 ;SF/GFT - MAKE APPOINTMENT ; May 10, 2021@19:53:47
+1 ;;5.3;Scheduling;**32,167,168,80,223,263,273,408,327,478,490,446,547,611,674,739,753,769,775**;Aug 13, 1993;Build 5
1 ;SD*5.3*753 - Remove unlock all
if $DATA(SDXXX)
QUIT
SET CCXN=0
KILL MXOK,COV,SDPROT
if DFN<0
QUIT
SET SC=+SC
+1 SET X1=DT
SET SDEDT=365
if $DATA(^SC(SC,"SDP"))
SET SDEDT=$PIECE(^SC(SC,"SDP"),"^",2)
+2 SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
DO WRT
+3 IF $DATA(^SC(SC,"SI"))
IF $ORDER(^("SI",0))>0
WRITE !,*7,?8,"**** SPECIAL INSTRUCTIONS ****",!
SET %I=0
FOR %=0:1
SET %I=$ORDER(^SC(SC,"SI",%I))
if %I'>0
QUIT
WRITE ^(%I,0)
if %
WRITE !
IF '%
IF $ORDER(^SC(SC,"SI",%I))>0
SET POP=0
DO SPIN
if POP
QUIT
+4 IF $DATA(SDINA)
IF SDINA>DT
DO IN
WRITE !,?8,@SDMSG
KILL SDMSG
+5 if SDMM
GOTO RDTY^SDMM
+6 ;
ADT if '$DATA(SDW)
SET SDW=""
+1 SET SDSOH=$SELECT('$DATA(^SC(SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
SET CCX=""
+2 ;Prevent repetitive iteration
SET SDONCE=$GET(SDONCE)+1
+3 ; Section introduced in 446.
+4 ; Removed EWL Decommisson - SD*5.3*769
+5 ;N SDDATE1,SDQT,Y ; Do not allow progress if there is no availability > 120 days after the desired date.
+6 ;S SDDATE1=$S($G(SDDATE)="":DT,1:SDDATE)
+7 ;S Y="" D Q:Y="^"
+8 ;.F Q:Y="^"!$$WLCL120^SDM2A(SC,SDDATE1) D
+9 ;..;S Y=$$WLCLASK^SDM2A() Q:Y="^" ; Y=0: New date, Y=1: place on EWL, Y="^": quit
+10 ;..I Y=0 D Q
+11 ;...N SDMAX,SDDMAX
+12 ;...S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
+13 ;...S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
+14 ;...S Y=$$DDATE^SDM0(.SDDATE,"0^0",.SDMAX) Q:'Y ; Y=0: "^" entered, Y=1: date entered
+15 ;...D D^SDM0
+16 ;...S SDDATE1=SDDATE
+17 ;...Q
+18 ;..D WL^SDM2A(SC)
+19 ;..S Y="^" ; quit
+20 ;..Q
+21 ;.Q
+22 ;
+23 ;Use default date/time if specified as 'desired date'
SET X=$SELECT(SDONCE<2:$GET(SDSDATE),1:"")
+24 ;!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446 - Removed EWl Decom, SD*5.3*769
IF 'X
READ !,"DATE/TIME: ",X:DTIME
if X="^"
QUIT
+25 ;I X="" D WL(SC) Q ;sd/446 - Removed EWl Decom, SD*5.3*769
+26 if X="M"!(X="m")
GOTO MORDIS^SDM0
+27 IF X="D"!(X="d")
SET X=$$REDDT()
if X>0
GOTO MORD2^SDM0
SET X=""
WRITE " ??",!
GOTO ADT
+28 IF X?1"?".E
Begin DoDot:1
+29 ;SD*547 added note about past dates
WRITE !,"Enter a date/time for the appointment - PAST dates must include the YEAR"
+30 if $DATA(SD)
WRITE " or a space to choose the same date/time as the patient you have just previously scheduled into this clinic"
+31 WRITE ".",!,"You may also select 'M' to display the next month's availability or"
+32 WRITE !,"'D' to specify an earlier or later date to begin the availability display."
End DoDot:1
GOTO ADT
+33 IF X=" "
IF $DATA(SD)
IF SD
SET Y=SD
DO AT^SDUTL
WRITE Y
SET Y=SD
GOTO OVR
+34 IF $EXTRACT($PIECE(X,"@",2),1,4)?1.4"0"
KILL %DT
SET X=$PIECE(X,"@")
SET X=$SELECT($LENGTH(X):X,1:"T")
SET %DT="XF"
DO ^%DT
if Y'>0
GOTO ADT
SET X1=Y
SET X2=-1
DO C^%DTC
SET X=X_.24
+35 KILL %DT
SET %DT="TXEF"
DO ^%DT
+36 ;SD*5.3*408 verify that day hasn't been canceled via "SET UP A CLINIC"
+37 IF $GET(^SC(+SC,"ST",$PIECE(Y,"."),1))'=""
IF ^SC(+SC,"ST",$PIECE(Y,"."),1)'["["
Begin DoDot:1
+38 WRITE !,"There is no availability for this date/time.",!
End DoDot:1
GOTO ADT
+39 IF $PIECE(Y,".",2)=24
SET X1=$PIECE(Y,".")
SET X2=1
DO C^%DTC
SET Y=X_".000001"
OVR IF $DATA(^HOLIDAY($PIECE(Y,"."),0))
IF 'SDSOH
WRITE *7,?50,$PIECE(^(0),U,2),"??"
KILL SDSDATE
GOTO ADT
+1 IF $DATA(SDINA)
IF $PIECE(Y,".")'<SDINA
IF $SELECT('$DATA(SDRE):1,SDRE>$PIECE(Y,".")!('SDRE):1,1:0)
DO IN
WRITE !,*7,@SDMSG
KILL SDMSG
KILL SDSDATE
GOTO ADT
+2 IF Y#1=0
KILL SDSDATE
GOTO 1
+3 IF $PIECE(Y,".")'<SDEDT
WRITE !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7
KILL SDSDATE
GOTO ADT
+4 ;
EN1 ;SD/478
SET (TMPD,X,SD)=Y
SET SM=0
DO DOW
+1 FOR S=$PIECE(SD,"."):0
SET S=+$ORDER(^DPT(DFN,"S",S))
if $PIECE(S,".")-($PIECE(SD,"."))
QUIT
SET I=+^(S,0)
if $PIECE(^(0),U,2)'["C"
GOTO ^SDM2
+2 ;
PRECAN IF $DATA(^DPT(DFN,"S",SD,0))
IF $PIECE(^(0),U,2)["P"
SET %=1
WRITE !,"THIS TIME WAS PREVIOUSLY CANCELLED BY THE PATIENT",!,"ARE YOU SURE THAT YOU WANT TO PROCEED"
DO YN^DICN
if '%
WRITE !,"ANSWER WITH (Y)ES OR (N)O"
IF (%-1)
KILL SDSDATE
GOTO ADT
+1 WRITE !
+2 ;SD*5.3*490 - AVCHK/AVCHK1 to check against pat DOB and clinic avail dt
S SET POP=0
DO AVCHK
if POP
GOTO 1
+1 SET POP=0
DO AVCHK1
if POP
GOTO 1
+2 ;New variables for Date check - SD*5.3*674
NEW SDBEGDT,DY
+3 ;SD*5.3*547 if selected date is prior to the date the day of the week was added to clinic, do not set the date into availability pattern
+4 IF '$DATA(^SC(SC,"ST",$PIECE(SD,"."),1))
Begin DoDot:1
+5 SET XDT=X
SET POP=0
+6 DO DOWCHK^SDM0
+7 ;Check if begin date of indefinite schedule is prior to appointment date - SD*5.3*674
SET SDBEGDT=$$BEGDAT^SDM0($PIECE(SD,"."),Y)
+8 KILL XDT
+9 if POP
KILL SDSDATE
End DoDot:1
+10 if POP
GOTO 1
+11 ;Indefinite schedule is prior to appointment date - SD*5.3*674
IF $GET(SDBEGDT)
SET DY=$$DOW^XLFDT($PIECE(SD,"."))
DO DWWRT^SDM0
GOTO 1
+12 KILL POP
+13 IF '$DATA(^SC(SC,"ST",$PIECE(SD,"."),1))
SET SS=+$ORDER(^SC(+SC,"T"_Y,SD))
if SS'>0
GOTO XW
if ^(SS,1)=""
GOTO XW
SET ^SC(+SC,"ST",$PIECE(SD,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(SD,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
SET ^(0)=$PIECE(SD,".")
+14 ;
LEN IF $PIECE(SL,U,2)]""
WRITE !,"LENGTH OF APPOINTMENT (IN MINUTES): ",+SL,"// "
READ S:DTIME
IF S]""
if $LENGTH(S)>3
GOTO LEN
if U[S
QUIT
SET POP=0
DO L
if POP
GOTO LEN
if S\5*5'=S
GOTO S
if S>360
GOTO S
if S<5
GOTO S
SET SL=S_U_$PIECE(SL,U,2,99)
+1 ;
SC SET SDLOCK=$SELECT('$DATA(SDLOCK):1,1:SDLOCK+1)
if SDLOCK>9
GOTO LOCK
+1 ;SD*53.*547 new required lock functionality
LOCK +^SC(SC,"ST",$PIECE(SD,"."),1):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
if '$TEST
GOTO SC
+2 SET SDLOCK=0
SET S=^SC(SC,"ST",$PIECE(SD,"."),1)
+3 SET I=SD#1-SB*100
SET ST=I#1*SI\.6+($PIECE(I,".")*SI)
SET SS=SL*HSI/60*SDDIF+ST+ST
+4 if (I<1!'$FIND(S,"["))&(S'["CAN")
GOTO X
+5 IF SM<7
SET %=$FIND(S,"[",SS-1)
if '%!($PIECE(SL,"^",6)<3)
SET %=999
IF $FIND(S,"]",SS)'<%!(SDDIF=2&$EXTRACT(S,ST+ST+1,SS-1)["[")
SET SM=7
+6 ;
SP IF ST+ST>$LENGTH(S)
IF $LENGTH(S)<80
SET S=S_" "
GOTO SP
+1 ;*775
NEW SDSLSV
+2 ;SD*5.3*490 naked Do added below
SET SDNOT=1
+3 ;SD*5.3*739 adds check for SDCAN node as CAN node is deleted when clinic is remapped
+4 ;SD*5.3*753 allows unlimited overbooks on nonscheduled availabilities in SDMULTIBOOK option, as is allowed in VSE and single appointment Vista
+5 FOR I=ST+ST:SDDIF:SS-SDDIF
SET ST=$EXTRACT(S,I+1)
if ST=""
SET ST=" "
SET Y=$SELECT("{}&%?#"[ST:ST,1:$EXTRACT(STR,$FIND(STR,ST)-2))
if S["CAN"!(ST="X"&(($DATA(^SC(+SC,"ST",$PIECE(SD,"."),"CAN")))!($ORDER(^SC(+SC,"SDCAN",$PIECE(SD,".")))<($PIECE(SD,".")+1))))
GOTO C
if Y=""
GOTO X
Begin DoDot:1
+6 if Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
Begin DoDot:2
+7 if ST'=""
QUIT
+8 if +SL'>+^SC(SC,"SL")
QUIT
+9 SET ST=" "
+10 QUIT
End DoDot:2
if ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
End DoDot:1
+11 ;SD*5.3*775 save SL to a namespaced variable
+12 if SDMM
QUIT
SET SDSLSV=SL
if SM#9=0
GOTO OK^SDM1A
if $PIECE(SL,U,7)]""&('$DATA(MXOK))
GOTO ^SDM3
+13 ;
E if '$DATA(^XUSEC("SDOB",DUZ))
GOTO NOOB
+1 SET %=2
WRITE *7,!,$EXTRACT($TEXT(@SM),5,99),"...OK"
DO YN^DICN
+2 IF '%
WRITE !,"RESPOND YES OR NO"
GOTO E
+3 SET SM=9
if '(%-1)
GOTO SC
KILL SDSDATE
GOTO 1
+4 ;
LOCK if SDMM
QUIT
WRITE !,*7,"ANOTHER USER HAS LOCKED THIS DATE - TRY AGAIN LATER"
QUIT
+1 ;
6 ;;OVERBOOK!
7 ;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD!
C SET POP=1
WRITE !,*7,"CAN'T BOOK WITHIN A CANCELLED TIME PERIOD!",!
+1 if SDMM
QUIT
KILL SDSDATE
GOTO 1
+2 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
DOW SET %=$EXTRACT(X,1,3)
SET Y=$EXTRACT(X,4,5)
SET Y=Y>2&'(%#4)+$EXTRACT("144025036146",Y)
+1 FOR %=%:-1:281
SET Y=%#4=1+1+Y
+2 SET Y=$EXTRACT(X,6,7)+Y#7
QUIT
+3 ;
X IF SDMM
SET POP=1
QUIT
+1 if I<1
GOTO XW
+2 if Y'?1NL&(SM<6)
SET SM=6
+3 if SM#9=0
GOTO OK^SDM1A
if $PIECE(SL,U,7)]""&('$DATA(MXOK))
GOTO ^SDM3
XW WRITE *7," WHEN??"
KILL SDSDATE
GOTO 1
+1 ;
AVCHK ;added SD*5.3*490
+1 IF '$DATA(VADM)
if 'DFN
QUIT
SET VADM(3)=$PIECE(^DPT(DFN,0),U,3)
+2 if $PIECE(X,".",1)=$PIECE(VADM(3),U,1)
QUIT
+3 IF $PIECE(X,".",1)<$PIECE(VADM(3),U,1)
WRITE *7,!!,"That date is prior to the patient's date of birth.",!!
SET POP=1
KILL SDSDATE
QUIT
+4 QUIT
+5 ;
AVCHK1 ;added SD*5.3*490
+1 SET AVDT=0
SET AVDT=$ORDER(^SC(+SC,"T",AVDT))
if 'AVDT
QUIT
+2 IF $PIECE(X,".",1)<AVDT
WRITE *7,!!,"That date is prior to the clinic's availability date.",!!
SET POP=1
KILL SDSDATE,AVDT
QUIT
+3 QUIT
+4 ;
NOOB WRITE !,"NO OPEN SLOTS THEN",*7
KILL SDSDATE
GOTO 1
+1 ;
WRT WRITE !,+SL," MINUTE APPOINTMENTS "
+1 WRITE $SELECT($PIECE(SL,U,2)["V":"(VARIABLE LENGTH)",1:"")
QUIT
+2 ;
L SET SDSL=$SELECT($PIECE(SL,"^",6)]"":60/$PIECE(SL,"^",6),1:"")
if 'SDSL
QUIT
+1 IF S\(SDSL)*(SDSL)'=S
WRITE *7,!,"Appt. length must = or be a multiple of the increment minutes per hour (",SDSL,")",!
SET POP=1
+2 QUIT
+3 ;
IN SET SDHY=$SELECT($DATA(Y):Y,1:"")
SET Y=SDINA
DO DTS^SDUTL
SET Y1=Y
SET Y=SDRE
+1 if Y
DO DTS^SDUTL
+2 SET SDMSG="""*** Note: Clinic is scheduled to be inactivated on "","_""""_Y1_""""_$SELECT(SDRE:",!,?10,"_""" and reactivated on "","_""""_Y_"""",1:"")
SET Y=SDHY
KILL Y1,SDHY
+3 QUIT
+4 ;
SPIN WRITE !,"There are more special instructions. Do you want to display them"
+1 SET %=2
DO YN^DICN
+2 IF '%
WRITE !,"Enter Y to see the remaining special instructions, or N if you don't wish to see them"
GOTO SPIN
+3 IF (%-1)
SET POP=1
QUIT
+4 WRITE !,^SC(SC,"SI",%I,0),!
QUIT
+5 ;
REDDT() ;Prompt for availability redisplay date
+1 NEW %DT,X,Y
+2 SET %DT="AEX"
+3 SET %DT("A")="DATE TO BEGIN THE RE-DISPLAY OF CLINIC AVAILABILITY: "
+4 WRITE !
DO ^%DT
+5 QUIT Y
WL(SC) ;Wait List Hook/teh patch 263 ;SD/327 passed 'SC'
+1 ;SD*5.3*769 - EWL DECOM
QUIT
+2 if $GET(SC)'>0
QUIT
+3 IF '$DATA(^SC(SC))
QUIT
+4 IF $DATA(SC)
SET SDWLFLG=0
Begin DoDot:1
+5 IF $DATA(^SDWL(409.32,"B",+SC))
SET SDWLFLG=1
+6 ; SD*5.3*611 DO command removed and second level dot structure removed
+7 IF 'SDWLFLG
SET SDWLDSS=$PIECE($GET(^SC(+SC,0)),U,7)
IF $DATA(^SDWL(409.31,"B",SDWLDSS))
SET SDWLFLG=2
+8 IF SDWLFLG=1
SET SDWLSC=$ORDER(^SDWL(409.32,"B",+SC,0))
IF $PIECE(^SDWL(409.32,SDWLSC,0),U,4)
SET SDWLFLG=0
+9 IF SDWLFLG=2
SET SDWLDS=$ORDER(^SDWL(409.31,"E",DUZ(2),0))
IF $DATA(^SDWL(409.31,SDWLDSS,"I",+SDWLDS,0))
IF $PIECE(^(0),U,4)
SET SDWLFLG=0
+10 IF SDWLFLG
Begin DoDot:2
+11 KILL SDWLSC,SDWLDSS,SDWLDS,SDWLFLG
+12 SET SDWLOPT=1
SET SDWLERR=0
DO OPT^SDWLE
DO EN^SDWLKIL
End DoDot:2
End DoDot:1
+13 QUIT
