SDM1 ;SF/GFT - MAKE APPOINTMENT ; 3/29/05 12:35pm
;;5.3;PIMS;**32,167,168,80,223,263,273,408,327,478,490,446,1005,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 12/13/2000 added check for overbook access by clinic
; 6/15/2001 print all special instructions
;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future booking<3 and appt on Monday, is okay
;
1 L Q:$D(SDXXX) S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0 S SC=+SC
S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
;
;IHS/OIT/LJF 03/08/2006 PATCH 1005 save maximum days for future booking parameter
NEW BSDMAX S BSDMAX=SDEDT
;
S X2=SDEDT D C^%DTC S SDEDT=X D WRT
;
;IHS/ANMC/LJF 6/15/2001 print all special instructions
;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(^SC(SC,"SI")),$O(^("SI",0))>0 W !,*7,?8,"**** SPECIAL INSTRUCTIONS ****",! S %I=0 F S %I=$O(^SC(SC,"SI",%I)) Q:%I'>0 W ^(%I,0),!
;IHS/ANMC/LJF 6/15/2001 end of changes
;
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
;ihs/cmi/maw 07/12/2012 PATCH 1015 removing 446 section TODO
; Section introduced in 446.
;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 ihs/cmi/maw PATCH 1015 07/12/2012 orig line
I 'X R !,"DATE/TIME: ",X:DTIME Q:X="^" ;!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446
I X="" D WL(SC) Q ;sd/446
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"
.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
;
;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future = 1 or 2, Monday appt okay
I BSDMAX<3,$$FMDIFF^XLFDT(Y,DT)<4,$$DOW^XLFDT(Y)="Monday" G EN1
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
;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
.K XDT
.K:POP SDSDATE
G:POP 1
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
S SDNOT=1 ;SD*5.3*490 naked Do added below
F I=ST+ST:SDDIF:SS-SDDIF S ST=$E(S,I+1) S:ST="" ST=" " S Y=$E(STR,$F(STR,ST)-2) G C:S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))),X:Y="" 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
Q:SDMM G OK^SDM1A:SM#9=0,^SDM3:$P(SL,U,7)]""&('$D(MXOK))
;
E ;G:'$D(^XUSEC("SDOB",DUZ)) NOOB ;IHS/ANMC/LJF 12/13/2000
G:'$$OVRBKUSR^BSDU(DUZ,+SC) NOOB ;IHS/ANMC/LJF 12/13/2000
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:$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
.I 'SDWLFLG S SDWLDSS=$P($G(^SC(+SC,0)),U,7) I $D(^SDWL(409.31,"B",SDWLDSS)) S SDWLFLG=2 D
..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
SDM1 ;SF/GFT - MAKE APPOINTMENT ; 3/29/05 12:35pm
+1 ;;5.3;PIMS;**32,167,168,80,223,263,273,408,327,478,490,446,1005,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 12/13/2000 added check for overbook access by clinic
+3 ; 6/15/2001 print all special instructions
+4 ;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future booking<3 and appt on Monday, is okay
+5 ;
1 LOCK
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 ;
+3 ;IHS/OIT/LJF 03/08/2006 PATCH 1005 save maximum days for future booking parameter
+4 NEW BSDMAX
SET BSDMAX=SDEDT
+5 ;
+6 SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
DO WRT
+7 ;
+8 ;IHS/ANMC/LJF 6/15/2001 print all special instructions
+9 ;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
+10 IF $DATA(^SC(SC,"SI"))
IF $ORDER(^("SI",0))>0
WRITE !,*7,?8,"**** SPECIAL INSTRUCTIONS ****",!
SET %I=0
FOR
SET %I=$ORDER(^SC(SC,"SI",%I))
IF %I'>0
QUIT
WRITE ^(%I,0),!
+11 ;IHS/ANMC/LJF 6/15/2001 end of changes
+12 ;
+13 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
+14 IF $DATA(SDINA)
IF SDINA>DT
DO IN
WRITE !,?8,@SDMSG
KILL SDMSG
+15 IF SDMM
GOTO RDTY^SDMM
+16 ;
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 ;ihs/cmi/maw 07/12/2012 PATCH 1015 removing 446 section TODO
+4 ; Section introduced in 446.
+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 ;I 'X R !,"DATE/TIME: ",X:DTIME Q:X="^"!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446 ihs/cmi/maw PATCH 1015 07/12/2012 orig line
+25 ;!'$$WLCL120A^SDM2A(X,SDDATE1,SC) ;sd/327,446
IF 'X
READ !,"DATE/TIME: ",X:DTIME
IF X="^"
QUIT
+26 ;sd/446
IF X=""
DO WL(SC)
QUIT
+27 IF X="M"!(X="m")
GOTO MORDIS^SDM0
+28 IF X="D"!(X="d")
SET X=$$REDDT()
IF X>0
GOTO MORD2^SDM0
SET X=""
WRITE " ??",!
GOTO ADT
+29 IF X?1"?".E
Begin DoDot:1
+30 WRITE !,"Enter a date/time for the appointment"
+31 IF $DATA(SD)
WRITE " or a space to choose the same date/time as the patient you have just previously scheduled into this clinic"
+32 WRITE ".",!,"You may also select 'M' to display the next month's availability or"
+33 WRITE !,"'D' to specify an earlier or later date to begin the availability display."
End DoDot:1
GOTO ADT
+34 IF X=" "
IF $DATA(SD)
IF SD
SET Y=SD
DO AT^SDUTL
WRITE Y
SET Y=SD
GOTO OVR
+35 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
+36 KILL %DT
SET %DT="TXEF"
DO ^%DT
+37 ;SD*5.3*408 verify that day hasn't been canceled via "SET UP A CLINIC"
+38 IF $GET(^SC(+SC,"ST",$PIECE(Y,"."),1))'=""
IF ^SC(+SC,"ST",$PIECE(Y,"."),1)'["["
Begin DoDot:1
+39 WRITE !,"There is no availability for this date/time.",!
End DoDot:1
GOTO ADT
+40 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 ;
+4 ;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future = 1 or 2, Monday appt okay
+5 IF BSDMAX<3
IF $$FMDIFF^XLFDT(Y,DT)<4
IF $$DOW^XLFDT(Y)="Monday"
GOTO EN1
+6 IF $PIECE(Y,".")'<SDEDT
WRITE !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7
KILL SDSDATE
GOTO ADT
+7 ;
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 ;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
+3 IF '$DATA(^SC(SC,"ST",$PIECE(SD,"."),1))
Begin DoDot:1
+4 SET XDT=X
SET POP=0
+5 DO DOWCHK^SDM0
+6 KILL XDT
+7 IF POP
KILL SDSDATE
End DoDot:1
+8 IF POP
GOTO 1
+9 KILL POP
+10 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,".")
+11 ;
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 ;SD*5.3*490 naked Do added below
SET SDNOT=1
+2 FOR I=ST+ST:SDDIF:SS-SDDIF
SET ST=$EXTRACT(S,I+1)
IF ST=""
SET ST=" "
SET Y=$EXTRACT(STR,$FIND(STR,ST)-2)
IF S["CAN"!(ST="X"&($DATA(^SC(+SC,"ST",$PIECE(SD,"."),"CAN"))))
GOTO C
IF Y=""
GOTO X
IF Y'?1NL&(SM<6)
SET SM=6
SET ST=$EXTRACT(S,I+2,999)
Begin DoDot:1
+3 IF ST'=""
QUIT
+4 IF +SL'>+^SC(SC,"SL")
QUIT
+5 SET ST=" "
+6 QUIT
End DoDot:1
IF ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I)_Y_ST
+7 IF SDMM
QUIT
IF SM#9=0
GOTO OK^SDM1A
IF $PIECE(SL,U,7)]""&('$DATA(MXOK))
GOTO ^SDM3
+8 ;
E ;G:'$D(^XUSEC("SDOB",DUZ)) NOOB ;IHS/ANMC/LJF 12/13/2000
+1 ;IHS/ANMC/LJF 12/13/2000
IF '$$OVRBKUSR^BSDU(DUZ,+SC)
GOTO NOOB
+2 SET %=2
WRITE *7,!,$EXTRACT($TEXT(@SM),5,99),"...OK"
DO YN^DICN
+3 IF '%
WRITE !,"RESPOND YES OR NO"
GOTO E
+4 SET SM=9
IF '(%-1)
GOTO SC
KILL SDSDATE
GOTO 1
+5 ;
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 IF $GET(SC)'>0
QUIT
+2 IF '$DATA(^SC(SC))
QUIT
+3 IF $DATA(SC)
SET SDWLFLG=0
Begin DoDot:1
+4 IF $DATA(^SDWL(409.32,"B",+SC))
SET SDWLFLG=1
+5 IF 'SDWLFLG
SET SDWLDSS=$PIECE($GET(^SC(+SC,0)),U,7)
IF $DATA(^SDWL(409.31,"B",SDWLDSS))
SET SDWLFLG=2
Begin DoDot:2
+6 IF SDWLFLG=1
SET SDWLSC=$ORDER(^SDWL(409.32,"B",+SC,0))
IF $PIECE(^SDWL(409.32,SDWLSC,0),U,4)
SET SDWLFLG=0
End DoDot:2
+7 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
+8 IF SDWLFLG
Begin DoDot:2
+9 KILL SDWLSC,SDWLDSS,SDWLDS,SDWLFLG
+10 SET SDWLOPT=1
SET SDWLERR=0
DO OPT^SDWLE
DO EN^SDWLKIL
End DoDot:2
End DoDot:1
+11 QUIT
