- 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**;Aug 13, 1993;Build 77
- 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
- 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
- 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,"?: "
- 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
- F SDZ=1:1:SDCN D MAKE^SDMM1 Q:$D(SDERRFT) D Q:POP
- .S:SDMADE SDMCNT=SDMCNT+1 I SDMADE,SDZ=1 S SDAPDT=SD
- .S SDMADE=0,POP=0 D GETNEX:SDTYP["W",GETNXD:SDTYP["D"
- .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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMM 6783 printed Feb 19, 2025@00:25:13 Page 2
- 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**;Aug 13, 1993;Build 77
- +2 NEW SDHX,SDAPDT
- SET SDMM=1
- DO ^SDM
- KILL SDMM
- QUIT
- RDTY ;SD/327
- KILL ^TMP($JOB,"APPT"),^TMP($JOB,"SDAMA301")
- +1 READ !,"WANT TO MAKE DAILY OR WEEKLY APPOINTMENTS?: WEEKLY// ",SDTYP:DTIME
- if SDTYP["^"!('$TEST)
- QUIT
- if SDTYP=""
- SET SDTYP="W"
- SET SDTYP=$$UP^XLFSTR($EXTRACT(SDTYP))
- IF "WD"'[SDTYP
- WRITE !,"ENTER 'D' FOR DAILY OR PRESS RETURN"
- GOTO RDTY
- 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
- RDC WRITE !,"FOR HOW MANY CONSECUTIVE ",$SELECT(SDTYP["W":$PIECE($TEXT(DAY),"^",Y+2)_"DAY'S",1:"DAYS")," DO YOU WANT APPOINTMENTS SCHEDULED",!," AT "
- SET X=SDOT
- DO TM
- WRITE X,"?: "
- +1 READ SDCN:DTIME
- if SDCN=""!(SDCN="^")
- GOTO ADT
- if SDCN'?.N
- GOTO HLP
- if SDCN<1
- GOTO HLP
- if SDCN>60
- GOTO HLP
- +2 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 FOR SDZ=1:1:SDCN
- DO MAKE^SDMM1
- if $DATA(SDERRFT)
- QUIT
- Begin DoDot:1
- +2 if SDMADE
- SET SDMCNT=SDMCNT+1
- IF SDMADE
- IF SDZ=1
- SET SDAPDT=SD
- +3 SET SDMADE=0
- SET POP=0
- if SDTYP["W"
- DO GETNEX
- if SDTYP["D"
- DO GETNXD
- +4 QUIT
- End DoDot:1
- if POP
- QUIT
- +5 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