SDMM ;SF/GFT,MAN/GRR - MULTIPLE APPOINTMENTS ; 2/7/05 12:51pm ; Compiled September 25, 2006 13:33:14
;;5.3;Scheduling;**26,32,167,241,327,446,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 9/20/2000 added code for biweekly & monthly booking
;cmi/anch/maw 1/20/2007 added flag in BEGIN so that pre appt letter prints once patch 1007 item 1007.13
;
N SDHX,SDAPDT S SDMM=1 D ^SDM K SDMM Q
RDTY K ^TMP($J,"APPT"),^TMP($J,"SDAMA301") ;SD/327
;R !,"WANT TO MAKE DAILY OR WEEKLY APPOINTMENTS?: WEEKLY// ",SDTYP:DTIME Q:SDTYP["^"!('$T) S:SDTYP="" SDTYP="W" S SDTYP=$$UP^XLFSTR($E(SDTYP)) I "WD"'[SDTYP W !,"ENTER 'D' FOR DAILY OR PRESS RETURN" G RDTY ;IHS/ANMC/LJF 9/20/2000
S SDTYP=$$READ^BDGF("SO^D:DAILY;W:WEEKLY;B:BIWEEKLY;M:MONTHLY","Select TYPE OF APPOINTMENTS","WEEKLY") I "DWBM"'[SDTYP S SDMCNT=+$G(SDMCNT) D END Q ;IHS/ANMC/LJF 9/20/2000
RD22 I SDTYP["D" S %=2 W !,"WANT APPOINTMENTS MADE ON SATURDAYS AND SUNDAYS" D YN^DICN S SDWE=$S(%<0:"^",%=2:"N",%=1:"Y",1:"?") Q:SDWE["^" G:SDWE["?" HLP22
ADT K SDERRFT S CCX=""
S X=$G(SDSDATE) S:X SDHX=X\1 K SDSDATE
W:X#1 !,"APPOINTMENT DATE/TIME REQUESTED: "
I '(X#1) R !,"DATE/TIME: ",X:DTIME I "^"[X K X,SD Q
I X="M"!(X="m") D MORDIS G ADT
I X="D"!(X="d") S X=$$REDDT^SDM1() D:X>0 MORD2 W:X="" $C(7)," ??",! G ADT
I X?1"?".E D HLP1 G ADT
I X=" ",$G(SDAPDT) S Y=SDAPDT D AT^SDUTL W Y S Y=SDAPDT 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
I $P(Y,".",2)=24 S X1=$P(Y,"."),X2=1 D C^%DTC S Y=X_".000001"
S SDSOH=$S('$D(^SC(+SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1)
OVR S SDY1=$P(Y,".") I $D(^HOLIDAY(SDY1,0)),'SDSOH W *7,?50,$P(^(0),U,2),"??" G ADT
I $D(SDINA),SDY1'<SDINA,$S('$D(SDRE):1,SDRE>SDY1!('SDRE):1,1:0) S SDY=Y,Y=SDINA D DTS^SDUTL W !,*7,"Clinic is scheduled to be inactivated on ",Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" and reactivated on "_Y,1:"") S Y=SDY K SDY G ADT
I Y#1=0 G ADT
D SDFT I $P(Y,".")'<SDEDT W !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7 G ADT
LEN I $P(SL,U,2)]"" W !,"LENGTH OF APPOINTMENTS (IN MINUTES): ",+SL,"// " R S:DTIME I S]"" G:$L(S)>3 LEN Q:U[S S POP=0 D L^SDM1 G LEN:POP I S\5*5=S,S'>360,S'<5 S SL=S_U_$P(SL,U,2,99)
S SDOT=Y#1,SDDAT=$P(Y,"."),X=Y D DOW^SDM0
;IHS/ANMC/LJF 9/20/2000
RDC ;W !,"FOR HOW MANY CONSECUTIVE ",$S(SDTYP["W":$P($T(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT " S X=SDOT D TM W X,"?: "
W !,"FOR HOW MANY CONSECUTIVE ",$S(SDTYP="M":"MONTHS",SDTYP="B":"EVERY OTHER "_$P($T(DAY),U,Y+2)_"DAY'S",SDTYP="W":$P($T(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT " S X=SDOT D TM W X,"?: "
;
R SDCN:DTIME G:SDCN=""!(SDCN="^") ADT G HLP:SDCN'?.N,HLP:SDCN<1,HLP:SDCN>60
S Y=SDDAT_SDOT,SDMCNT=0,SDMADE=0
OTHER R !," OTHER INFO: ",D:DTIME I D["^" W !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered" G OTHER
I $L(D)>150 D MSG G OTHER
I D]"",D?."?"!(D'?.ANP) W " ENTER LAB, SCAN, ETC." G OTHER
I $L(D)+$L(SDW)>250 D MSG G OTHER
BEGIN S SDZM=1,SDZY=Y,SDX9=X,SDM9=D D SDMM^SDM1A K SDZM S Y=SDZY,X=SDX9,D=SDM9
;cmi/anch/maw 1/20/2007 added flag here so APPT SLIP doesn't print until the end PATCH 1007 item 1007.13
S BSDMK=1 ;cmi/maw 1/20/2007 PATCH 1007 item 1007.13
F SDZ=1:1:SDCN D MAKE^SDMM1 Q:$D(SDERRFT) D Q:POP
. I (SDCN-1)=SDZ K BSDMK ;cmi/maw 1/20/2007 PATCH 1007 item 1007.13
.S:SDMADE SDMCNT=SDMCNT+1 I SDMADE,SDZ=1 S SDAPDT=SD
.;
.;S SDMADE=0,POP=0 D GETNEX:SDTYP["W",GETNXD:SDTYP["D" ;IHS/ANMC/LJF 9/20/2000
.S SDMADE=0,POP=0 S X=$S(SDTYP="W":"GETNEX",SDTYP="D":"GETNXD",SDTYP="B":"GETNXB^BSDMM",1:"GETNXM^BSDMM") D @X ;IHS/ANMC/LJF 9/20/2000
.;
.Q
G:$D(SDERRFT) ADT
END W !,SDMCNT," APPOINTMENTS MADE",!
;display all created appointments
I $D(^TMP($J,"APPT")) N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
.K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
.D INIT^SDWLPL(DFN,"M")
.Q:'$D(^TMP($J,"SDWLPL")) ;
.;D LIST^SDWLPL("M",DFN) ;display EWL entries
.F Q:'$D(^TMP($J,"SDWLPL")) D LIST^SDWLPL("M",DFN) N SDR D ANSW^SDWLEVAL(1,.SDR) I 'SDR D ;D LIST^SDWLPL("M",DFN) D
..F N SDR D ANSW^SDWLEVAL(0,.SDR) Q:'$D(^TMP($J,"SDWLPL")) I 'SDR W !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
I $D(^TMP($J,"APPT")) N SDEV D EN^SDWLEVAL(DFN,.SDEV) I SDEV,$L(SDEV(1))>0 D
.;N SDTC D EWLANS^SDWLEVAL(.SDTC) ;user may reject EWL; 446/;
.;ask for selection of EWL to display
.;ASKS - returned answer (A/C/S/^)
.; ^TMP("SDWLPL",$J) and ^TMP($J,"SDWLPL") are used
.; to generate EWL open entries
.;I SDTC N SDCTN S SDCTN=0 F N ASKS K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL") D ANS2^SDWLPL(DFN,.ASKS) Q:ASKS="^" D Q:SDCTN ;446/;
.Q:'$D(^TMP($J,"SDWLPL")) D ASKREM^SDWLEVAL S SDCTN=1 ;display and process selected open EWL entries ;446/;
.;I 'SDTC Q ;no EWL evaluation per user's decision
.Q
;
K CCX,COLLAT,COV,D,I,POP,S,SC,SD,SDAPTYP,SDEDT,SDEMP,SDINA,SDLOCK,SDM9,SDMES,SDNOT,SDRE,SDSOH,SDW,SDWEE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZ,SDZY,SDMES,SDCN,SDDAT,SDMADE,SDMCNT,SDOT,SDPL,SDRT,SDSC,SDTTM,SDTYP
K SDALLE,SDATD,SDAV,SDDECOD,SDEC,SDHX,SDIN,SDINP,SDOEL,SDT,SDY,%H,%T,C,DISYS,SDW,SDWE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZY,SI,SL,SM,SS,X1,X2,Y,SDXF,% Q
GETNEX I SDDAT#100<22 S SDDAT=SDDAT+7 S POP=0 D INACT Q:POP G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNEX S Y=SDDAT_SDOT Q
S X1=SDDAT,X2=7 D C^%DTC S POP=0 D INACT Q:POP S SDDAT=X G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNEX S Y=SDDAT_SDOT
Q
GETNXD I SDDAT#100<28 S SDDAT=SDDAT+1 S POP=0 D INACT Q:POP G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNXD S X=SDDAT D DOW^SDM0 S:SDWE["Y" Y=SDDAT_SDOT Q:SDWE["Y" G:Y=0!(Y=6) GETNXD S Y=SDDAT_SDOT Q
S X1=SDDAT,X2=1 D C^%DTC S POP=0 D INACT Q:POP S SDDAT=X G:$D(^HOLIDAY(SDDAT,0))&('SDSOH) GETNXD S X=SDDAT D DOW^SDM0 S:SDWE["Y" Y=SDDAT_SDOT Q:SDWE["Y" G:Y=0!(Y=6) GETNXD S Y=SDDAT_SDOT
Q
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
TM S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" Q
HLP W !,"Enter the number of appointments you want made (between 1 and 60)." G RDC
HLP22 W !,"ENTER 'YES' IF YOU WANT THE SYSTEM TO TRY TO MAKE APPOINTMENTS ON SATURDAYS AND SUNDAYS" G RD22
INACT I $D(SDINA),SDINA'>SDDAT,SDRE>SDDAT!('SDRE) W !,*7,"Appointments can't be made while clinic is inactivated" S POP=1
Q
HLP1 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."
Q
SDFT S X1=DT,SDEDT=$S($D(^SC(SC,"SDP")):$P(^("SDP"),U,2),1:365) S:'SDEDT SDEDT=365 S X2=SDEDT D C^%DTC S SDEDT=X Q
MSG W !!?5,"Text entered at OTHER INFO prompt was too long. Please re-enter.",! Q
;
MORDIS I '$D(SDHX) W *7," ??" G ADT
S SDXF=0,X1=SDHX,X2=1 D C^%DTC
MORD2 I $D(SDINA),SDINA'>X,SDRE>X!('SDRE) S SDHY=$S($D(Y):Y,1:""),Y=SDINA D DTS^SDUTL W *7,!,"Clinic is inactivated as of ",Y S Y=SDHY K SDHY G ADT
EN S:$L(X)=1 X=$TR(X,"tnN","TTT") S:X="NOW" X="T" I X?.A!(+X=X),X<13,X'?1"T".E S X=X_" 1"
D Q:Y<1
.N %DT
.S %DT="T" D ^%DT
.I Y<1 W !!,"Unable to evaluate date value """_X_""".",!
.Q
S:$S($D(DUZ)'[0:1,1:0) ^DISV(DUZ_U_+SC)=Y
DISP S IOF=$S('$D(IOF):"!#",IOF']"":"!#",1:IOF) W @IOF S SDSOH=$S('$D(^SC(+SC,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1),SDAV=0
I $D(SDINA),Y'<SDINA,SDRE>Y!('SDRE) S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"") S Y=SDHY K SDHY Q:'SDRE
S:Y#100=0 Y=Y+1 S X=Y D D^SDM0:$E(X,4,5) S (SDX,X1)=X,X2=1 D C^%DTC S X=SDX K SDX Q
SDMM ;SF/GFT,MAN/GRR - MULTIPLE APPOINTMENTS ; 2/7/05 12:51pm ; Compiled September 25, 2006 13:33:14
+1 ;;5.3;Scheduling;**26,32,167,241,327,446,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 9/20/2000 added code for biweekly & monthly booking
+3 ;cmi/anch/maw 1/20/2007 added flag in BEGIN so that pre appt letter prints once patch 1007 item 1007.13
+4 ;
+5 NEW SDHX,SDAPDT
SET SDMM=1
DO ^SDM
KILL SDMM
QUIT
RDTY ;SD/327
KILL ^TMP($JOB,"APPT"),^TMP($JOB,"SDAMA301")
+1 ;R !,"WANT TO MAKE DAILY OR WEEKLY APPOINTMENTS?: WEEKLY// ",SDTYP:DTIME Q:SDTYP["^"!('$T) S:SDTYP="" SDTYP="W" S SDTYP=$$UP^XLFSTR($E(SDTYP)) I "WD"'[SDTYP W !,"ENTER 'D' FOR DAILY OR PRESS RETURN" G RDTY ;IHS/ANMC/LJF 9/20/2000
+2 ;IHS/ANMC/LJF 9/20/2000
SET SDTYP=$$READ^BDGF("SO^D:DAILY;W:WEEKLY;B:BIWEEKLY;M:MONTHLY","Select TYPE OF APPOINTMENTS","WEEKLY")
IF "DWBM"'[SDTYP
SET SDMCNT=+$GET(SDMCNT)
DO END
QUIT
RD22 IF SDTYP["D"
SET %=2
WRITE !,"WANT APPOINTMENTS MADE ON SATURDAYS AND SUNDAYS"
DO YN^DICN
SET SDWE=$SELECT(%<0:"^",%=2:"N",%=1:"Y",1:"?")
IF SDWE["^"
QUIT
IF SDWE["?"
GOTO HLP22
ADT KILL SDERRFT
SET CCX=""
+1 SET X=$GET(SDSDATE)
IF X
SET SDHX=X\1
KILL SDSDATE
+2 IF X#1
WRITE !,"APPOINTMENT DATE/TIME REQUESTED: "
+3 IF '(X#1)
READ !,"DATE/TIME: ",X:DTIME
IF "^"[X
KILL X,SD
QUIT
+4 IF X="M"!(X="m")
DO MORDIS
GOTO ADT
+5 IF X="D"!(X="d")
SET X=$$REDDT^SDM1()
IF X>0
DO MORD2
IF X=""
WRITE $CHAR(7)," ??",!
GOTO ADT
+6 IF X?1"?".E
DO HLP1
GOTO ADT
+7 IF X=" "
IF $GET(SDAPDT)
SET Y=SDAPDT
DO AT^SDUTL
WRITE Y
SET Y=SDAPDT
GOTO OVR
+8 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
+9 KILL %DT
SET %DT="TXEF"
DO ^%DT
+10 IF $PIECE(Y,".",2)=24
SET X1=$PIECE(Y,".")
SET X2=1
DO C^%DTC
SET Y=X_".000001"
+11 SET SDSOH=$SELECT('$DATA(^SC(+SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
OVR SET SDY1=$PIECE(Y,".")
IF $DATA(^HOLIDAY(SDY1,0))
IF 'SDSOH
WRITE *7,?50,$PIECE(^(0),U,2),"??"
GOTO ADT
+1 IF $DATA(SDINA)
IF SDY1'<SDINA
IF $SELECT('$DATA(SDRE):1,SDRE>SDY1!('SDRE):1,1:0)
SET SDY=Y
SET Y=SDINA
DO DTS^SDUTL
WRITE !,*7,"Clinic is scheduled to be inactivated on ",Y
SET Y=SDRE
IF Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" and reactivated on "_Y,1:"")
SET Y=SDY
KILL SDY
GOTO ADT
+2 IF Y#1=0
GOTO ADT
+3 DO SDFT
IF $PIECE(Y,".")'<SDEDT
WRITE !,*7,"EXCEEDS MAXIMUM DAYS FOR FUTURE APPOINTMENT!!",*7
GOTO ADT
LEN IF $PIECE(SL,U,2)]""
WRITE !,"LENGTH OF APPOINTMENTS (IN MINUTES): ",+SL,"// "
READ S:DTIME
IF S]""
IF $LENGTH(S)>3
GOTO LEN
IF U[S
QUIT
SET POP=0
DO L^SDM1
IF POP
GOTO LEN
IF S\5*5=S
IF S'>360
IF S'<5
SET SL=S_U_$PIECE(SL,U,2,99)
+1 SET SDOT=Y#1
SET SDDAT=$PIECE(Y,".")
SET X=Y
DO DOW^SDM0
+2 ;IHS/ANMC/LJF 9/20/2000
RDC ;W !,"FOR HOW MANY CONSECUTIVE ",$S(SDTYP["W":$P($T(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT " S X=SDOT D TM W X,"?: "
+1 WRITE !,"FOR HOW MANY CONSECUTIVE ",$SELECT(SDTYP="M":"MONTHS",SDTYP="B":"EVERY OTHER "_$PIECE($TEXT(DAY),U,Y+2)_"DAY'S",SDTYP="W":$PIECE($TEXT(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT "
SET X=SDOT
DO TM
WRITE X,"?: "
+2 ;
+3 READ SDCN:DTIME
IF SDCN=""!(SDCN="^")
GOTO ADT
IF SDCN'?.N
GOTO HLP
IF SDCN<1
GOTO HLP
IF SDCN>60
GOTO HLP
+4 SET Y=SDDAT_SDOT
SET SDMCNT=0
SET SDMADE=0
OTHER READ !," OTHER INFO: ",D:DTIME
IF D["^"
WRITE !,*7,"'^' not allowed - hit return if no 'OTHER INFO' is to be entered"
GOTO OTHER
+1 IF $LENGTH(D)>150
DO MSG
GOTO OTHER
+2 IF D]""
IF D?."?"!(D'?.ANP)
WRITE " ENTER LAB, SCAN, ETC."
GOTO OTHER
+3 IF $LENGTH(D)+$LENGTH(SDW)>250
DO MSG
GOTO OTHER
BEGIN SET SDZM=1
SET SDZY=Y
SET SDX9=X
SET SDM9=D
DO SDMM^SDM1A
KILL SDZM
SET Y=SDZY
SET X=SDX9
SET D=SDM9
+1 ;cmi/anch/maw 1/20/2007 added flag here so APPT SLIP doesn't print until the end PATCH 1007 item 1007.13
+2 ;cmi/maw 1/20/2007 PATCH 1007 item 1007.13
SET BSDMK=1
+3 FOR SDZ=1:1:SDCN
DO MAKE^SDMM1
IF $DATA(SDERRFT)
QUIT
Begin DoDot:1
+4 ;cmi/maw 1/20/2007 PATCH 1007 item 1007.13
IF (SDCN-1)=SDZ
KILL BSDMK
+5 IF SDMADE
SET SDMCNT=SDMCNT+1
IF SDMADE
IF SDZ=1
SET SDAPDT=SD
+6 ;
+7 ;S SDMADE=0,POP=0 D GETNEX:SDTYP["W",GETNXD:SDTYP["D" ;IHS/ANMC/LJF 9/20/2000
+8 ;IHS/ANMC/LJF 9/20/2000
SET SDMADE=0
SET POP=0
SET X=$SELECT(SDTYP="W":"GETNEX",SDTYP="D":"GETNXD",SDTYP="B":"GETNXB^BSDMM",1:"GETNXM^BSDMM")
DO @X
+9 ;
+10 QUIT
End DoDot:1
IF POP
QUIT
+11 IF $DATA(SDERRFT)
GOTO ADT
END WRITE !,SDMCNT," APPOINTMENTS MADE",!
+1 ;display all created appointments
+2 IF $DATA(^TMP($JOB,"APPT"))
NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+3 KILL ^TMP("SDWLPL",$JOB),^TMP($JOB,"SDWLPL")
+4 DO INIT^SDWLPL(DFN,"M")
+5 ;
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
+6 ;D LIST^SDWLPL("M",DFN) ;display EWL entries
+7 ;D LIST^SDWLPL("M",DFN) D
FOR
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
DO LIST^SDWLPL("M",DFN)
NEW SDR
DO ANSW^SDWLEVAL(1,.SDR)
IF 'SDR
Begin DoDot:2
+8 FOR
NEW SDR
DO ANSW^SDWLEVAL(0,.SDR)
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
IF 'SDR
WRITE !,"MUST ENTER A REASON NOT TO DISPOSITION MATCHED EWL ENTRY",!
End DoDot:2
End DoDot:1
+9 IF $DATA(^TMP($JOB,"APPT"))
NEW SDEV
DO EN^SDWLEVAL(DFN,.SDEV)
IF SDEV
IF $LENGTH(SDEV(1))>0
Begin DoDot:1
+10 ;N SDTC D EWLANS^SDWLEVAL(.SDTC) ;user may reject EWL; 446/;
+11 ;ask for selection of EWL to display
+12 ;ASKS - returned answer (A/C/S/^)
+13 ; ^TMP("SDWLPL",$J) and ^TMP($J,"SDWLPL") are used
+14 ; to generate EWL open entries
+15 ;I SDTC N SDCTN S SDCTN=0 F N ASKS K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL") D ANS2^SDWLPL(DFN,.ASKS) Q:ASKS="^" D Q:SDCTN ;446/;
+16 ;display and process selected open EWL entries ;446/;
IF '$DATA(^TMP($JOB,"SDWLPL"))
QUIT
DO ASKREM^SDWLEVAL
SET SDCTN=1
+17 ;I 'SDTC Q ;no EWL evaluation per user's decision
+18 QUIT
End DoDot:1
+19 ;
+20 KILL CCX,COLLAT,COV,D,I,POP,S,SC,SD,SDAPTYP,SDEDT,SDEMP,SDINA,SDLOCK,SDM9,SDMES,SDNOT,SDRE,SDSOH,SDW,SDWEE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZ,SDZY,SDMES,SDCN,SDDAT,SDMADE,SDMCNT,SDOT,SDPL,SDRT,SDSC,SDTTM,SDTYP
+21 KILL SDALLE,SDATD,SDAV,SDDECOD,SDEC,SDHX,SDIN,SDINP,SDOEL,SDT,SDY,%H,%T,C,DISYS,SDW,SDWE,SDX3,SDX7,SDX9,SDY1,SDYC,SDZY,SI,SL,SM,SS,X1,X2,Y,SDXF,%
QUIT
GETNEX IF SDDAT#100<22
SET SDDAT=SDDAT+7
SET POP=0
DO INACT
IF POP
QUIT
IF $DATA(^HOLIDAY(SDDAT,0))&('SDSOH)
GOTO GETNEX
SET Y=SDDAT_SDOT
QUIT
+1 SET X1=SDDAT
SET X2=7
DO C^%DTC
SET POP=0
DO INACT
IF POP
QUIT
SET SDDAT=X
IF $DATA(^HOLIDAY(SDDAT,0))&('SDSOH)
GOTO GETNEX
SET Y=SDDAT_SDOT
+2 QUIT
GETNXD IF SDDAT#100<28
SET SDDAT=SDDAT+1
SET POP=0
DO INACT
IF POP
QUIT
IF $DATA(^HOLIDAY(SDDAT,0))&('SDSOH)
GOTO GETNXD
SET X=SDDAT
DO DOW^SDM0
IF SDWE["Y"
SET Y=SDDAT_SDOT
IF SDWE["Y"
QUIT
IF Y=0!(Y=6)
GOTO GETNXD
SET Y=SDDAT_SDOT
QUIT
+1 SET X1=SDDAT
SET X2=1
DO C^%DTC
SET POP=0
DO INACT
IF POP
QUIT
SET SDDAT=X
IF $DATA(^HOLIDAY(SDDAT,0))&('SDSOH)
GOTO GETNXD
SET X=SDDAT
DO DOW^SDM0
IF SDWE["Y"
SET Y=SDDAT_SDOT
IF SDWE["Y"
QUIT
IF Y=0!(Y=6)
GOTO GETNXD
SET Y=SDDAT_SDOT
+2 QUIT
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
TM SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET %=X>1159
IF X>1259
SET X=X-1200
SET X=X\100_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",%+1)_"M"
QUIT
HLP WRITE !,"Enter the number of appointments you want made (between 1 and 60)."
GOTO RDC
HLP22 WRITE !,"ENTER 'YES' IF YOU WANT THE SYSTEM TO TRY TO MAKE APPOINTMENTS ON SATURDAYS AND SUNDAYS"
GOTO RD22
INACT IF $DATA(SDINA)
IF SDINA'>SDDAT
IF SDRE>SDDAT!('SDRE)
WRITE !,*7,"Appointments can't be made while clinic is inactivated"
SET POP=1
+1 QUIT
HLP1 WRITE !,"Enter a date/time for the appointment"
+1 IF $DATA(SD)
WRITE " or a space to choose the same date/time",!,"as the patient you have just previously scheduled into this clinic"
+2 WRITE ".",!,"You may also select 'M' to display the next month's availability or"
+3 WRITE !,"'D' to specify an earlier or later date to begin the availability display."
+4 QUIT
SDFT SET X1=DT
SET SDEDT=$SELECT($DATA(^SC(SC,"SDP")):$PIECE(^("SDP"),U,2),1:365)
IF 'SDEDT
SET SDEDT=365
SET X2=SDEDT
DO C^%DTC
SET SDEDT=X
QUIT
MSG WRITE !!?5,"Text entered at OTHER INFO prompt was too long. Please re-enter.",!
QUIT
+1 ;
MORDIS IF '$DATA(SDHX)
WRITE *7," ??"
GOTO ADT
+1 SET SDXF=0
SET X1=SDHX
SET X2=1
DO C^%DTC
MORD2 IF $DATA(SDINA)
IF SDINA'>X
IF SDRE>X!('SDRE)
SET SDHY=$SELECT($DATA(Y):Y,1:"")
SET Y=SDINA
DO DTS^SDUTL
WRITE *7,!,"Clinic is inactivated as of ",Y
SET Y=SDHY
KILL SDHY
GOTO ADT
EN IF $LENGTH(X)=1
SET X=$TRANSLATE(X,"tnN","TTT")
IF X="NOW"
SET X="T"
IF X?.A!(+X=X)
IF X<13
IF X'?1"T".E
SET X=X_" 1"
+1 Begin DoDot:1
+2 NEW %DT
+3 SET %DT="T"
DO ^%DT
+4 IF Y<1
WRITE !!,"Unable to evaluate date value """_X_""".",!
+5 QUIT
End DoDot:1
IF Y<1
QUIT
+6 IF $SELECT($DATA(DUZ)'[0
SET ^DISV(DUZ_U_+SC)=Y
DISP SET IOF=$SELECT('$DATA(IOF):"!#",IOF']"":"!#",1:IOF)
WRITE @IOF
SET SDSOH=$SELECT('$DATA(^SC(+SC,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
SET SDAV=0
+1 IF $DATA(SDINA)
IF Y'<SDINA
IF SDRE>Y!('SDRE)
SET SDHY=Y
SET Y=SDINA
DO DTS^SDUTL
WRITE !,*7,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
SET Y=SDRE
IF Y
DO DTS^SDUTL
WRITE $SELECT(SDRE:" to "_Y,1:"")
SET Y=SDHY
KILL SDHY
IF 'SDRE
QUIT
+2 IF Y#100=0
SET Y=Y+1
SET X=Y
IF $EXTRACT(X,4,5)
DO D^SDM0
SET (SDX,X1)=X
SET X2=1
DO C^%DTC
SET X=SDX
KILL SDX
QUIT
