SDM1.m

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 ---SDM1   8665     printed  Feb 19, 2025@00:24:48                                                                                                                                                                                                        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