SDMULT1 ;ALB/TMP - MAKE MULTI-CLINIC APPOINTMENTS ; 18 APR 86
;;5.3;Scheduling;**32,41,167**;AUG 13, 1993
;
FND I $D(SDNEXT) S SDPCM1=""
I $D(SDNEXT),$G(SDPCMM(SC))>2 K SDPCM1 G ACT
I $D(SDNEXT),+$G(SDPCMM(SC))<1 W @IOF
I '$D(SDNEXT) W @IOF
W !?25,"DATE: " S X=SDAPP D DOW^SDM0 W "(",$P($P($T(DAY),";",3),"^",Y+2),"DAY) " S Y=SDAPP D DT^DIQ W ! F G1=0:0 S G1=$O(SDC(G1)) Q:G1'>0 S SC=+SDC(G1) D S2 S X=SDAPP,SCPCMM(SC)=0 D PROC
ACT I '$D(SDPCMM) W:'$D(SDNEXT) ! W !,"ENTER: ",!,?3,"'^' - EXIT " W:'$D(SDNEXT) "'B' - BOOK " W "'C' - CONTINUE SEARCH or 'R' - REDISPLAY: CONTINUE// " R X:DTIME G:X["^" END^SDMULT0 S X=$E(X) I X?1"?"!("BCR"'[X) D H1 G ACT
I '$D(SDPCMM),$D(SDNEXT) S SDNEXT=1
I $D(SDPCM1) S X="C"
I X["C"!(X']"") S FND=0 F I=1:1:SDCT S SDDT(I)=0
I S X1=SDSTRTDT,X2=1 D C^%DTC S SDSTRTDT=X G LOOKA^SDMULT0
I X["R" G FND
I X["B",'$D(SDNEXT) G BOOK
I '$D(SDPCMM) K SDPCM1 D H1 G ACT
PROC I $D(SDNEXT) S SDPCMM(SC)=$G(SDPCMM(SC))+1
I $D(SDNEXT),$G(SDPCMM(SC))>3 K SDPCM1 Q
S SDV="",$P(SDV," ",SI+SI-5)="" W !,"CLINIC: ",$P(SDC1(SC),"^",1),?50,"(",$P(SDC1(SC),"^",2)," MINUTES)",!,"-------" S LINE=" TIME"_SDV F Y=STARTDAY:1:65\(SI+SI)+STARTDAY S LINE=LINE_$E("|"_$S('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
W !,$E(LINE,1,80) S LINE(G1)=$E(LINE,1,80)
W !,$E(^SC(SC,"ST",SDAPP,1),1,80),! S LINE1(G1)=$E(^(1),1,80) Q
H1 W !,"YOU MAY ENTER:",!,?10,"'^' TO EXIT" W:'$D(SDNEXT) !,?10,"'B' TO ENTER THE MAKE APPT ROUTINES AND BOOK THE APPOINTMENTS"
W !,?10,"'C' TO LOOK FOR THE NEXT DATE ALL CLINICS HAVE AN AVAILABLE TIME SLOT",!,?10,"'R' TO REDISPLAY THIS SAME SCREEN" Q
;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
;
BOOK D STARS
F G1=0:0 S G1=$O(SDC(G1)) Q:G1'>0 W !!,"Make appt in : ",$P(SDC(G1),"^",2),! S SC=+SDC(G1) D S2,S3,TM D:SDMADE MADE D:'SDMADE NOT
K COLLAT G END^SDMULT0
MADE W !!,$P(^SC(+SDC(G1),"S",SD,1,SDY,0),"^",2)," minute appointment made in ",$P(SDC(G1),"^",2),! D STARS
Q
NOT W !!,"No appt made in ",$P(SDC1(SC),"^"),! D STARS
Q
STARS S SD0="",$P(SD0,"*",81)="" W !,SD0 K SD0 Q
TM S SDMADE=0 R !!,"SCHEDULE TIME: ",X:DTIME Q:"^"[X!'($T) I X?.E1"?"!(X'?1N.N) W !,"Enter the appointment time for this clinic" G TM
S X=$E(SDAPP,4,7)_$E(SDAPP,2,3)_"@"_X,%DT="TE" D ^%DT I Y<0 W *7," WHEN ??" G TM
K %DT S X=Y#1,Y=+Y I $D(^DPT(DFN,"S",Y,0)),$P(^(0),"^",2)'["C" S Y1=+^(0),Y1=$P(^SC(+Y1,0),"^") W !,*7,"Patient already has an appointment in ",Y1," at that time" K Y1 G TM
S:$P(SL,"^",2)]"" $P(SL,"^")=$P(SDC1(SC),"^",2) S SDMLT=1 K SDAPTYP D EN1^SDM1
G:'SDMADE!(SDMADE=2) TM Q
S2 S SL=^SC(SC,"SL"),X=$P(SL,"^",3),STARTDAY=$S($L(X):X,1:8),X=$P(SL,"^",6),SI=$S(X="":4,X<3:4,X:X,1:4) Q
S3 W !,LINE(G1),!,LINE1(G1)
S SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2),SM=0
K MXOK S SD=SDAPP,(CCX,CCXN,DP)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDMULT1 2909 printed Apr 09, 2024@22:00:29 Page 2
SDMULT1 ;ALB/TMP - MAKE MULTI-CLINIC APPOINTMENTS ; 18 APR 86
+1 ;;5.3;Scheduling;**32,41,167**;AUG 13, 1993
+2 ;
FND IF $DATA(SDNEXT)
SET SDPCM1=""
+1 IF $DATA(SDNEXT)
IF $GET(SDPCMM(SC))>2
KILL SDPCM1
GOTO ACT
+2 IF $DATA(SDNEXT)
IF +$GET(SDPCMM(SC))<1
WRITE @IOF
+3 IF '$DATA(SDNEXT)
WRITE @IOF
+4 WRITE !?25,"DATE: "
SET X=SDAPP
DO DOW^SDM0
WRITE "(",$PIECE($PIECE($TEXT(DAY),";",3),"^",Y+2),"DAY) "
SET Y=SDAPP
DO DT^DIQ
WRITE !
FOR G1=0:0
SET G1=$ORDER(SDC(G1))
if G1'>0
QUIT
SET SC=+SDC(G1)
DO S2
SET X=SDAPP
SET SCPCMM(SC)=0
DO PROC
ACT IF '$DATA(SDPCMM)
if '$DATA(SDNEXT)
WRITE !
WRITE !,"ENTER: ",!,?3,"'^' - EXIT "
if '$DATA(SDNEXT)
WRITE "'B' - BOOK "
WRITE "'C' - CONTINUE SEARCH or 'R' - REDISPLAY: CONTINUE// "
READ X:DTIME
if X["^"
GOTO END^SDMULT0
SET X=$EXTRACT(X)
IF X?1"?"!("BCR"'[X)
DO H1
GOTO ACT
+1 IF '$DATA(SDPCMM)
IF $DATA(SDNEXT)
SET SDNEXT=1
+2 IF $DATA(SDPCM1)
SET X="C"
+3 IF X["C"!(X']"")
SET FND=0
FOR I=1:1:SDCT
SET SDDT(I)=0
+4 IF $TEST
SET X1=SDSTRTDT
SET X2=1
DO C^%DTC
SET SDSTRTDT=X
GOTO LOOKA^SDMULT0
+5 IF X["R"
GOTO FND
+6 IF X["B"
IF '$DATA(SDNEXT)
GOTO BOOK
+7 IF '$DATA(SDPCMM)
KILL SDPCM1
DO H1
GOTO ACT
PROC IF $DATA(SDNEXT)
SET SDPCMM(SC)=$GET(SDPCMM(SC))+1
+1 IF $DATA(SDNEXT)
IF $GET(SDPCMM(SC))>3
KILL SDPCM1
QUIT
+2 SET SDV=""
SET $PIECE(SDV," ",SI+SI-5)=""
WRITE !,"CLINIC: ",$PIECE(SDC1(SC),"^",1),?50,"(",$PIECE(SDC1(SC),"^",2)," MINUTES)",!,"-------"
SET LINE=" TIME"_SDV
FOR Y=STARTDAY:1:65\(SI+SI)+STARTDAY
SET LINE=LINE_$EXTRACT("|"_$SELECT('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
+3 WRITE !,$EXTRACT(LINE,1,80)
SET LINE(G1)=$EXTRACT(LINE,1,80)
+4 WRITE !,$EXTRACT(^SC(SC,"ST",SDAPP,1),1,80),!
SET LINE1(G1)=$EXTRACT(^(1),1,80)
QUIT
H1 WRITE !,"YOU MAY ENTER:",!,?10,"'^' TO EXIT"
if '$DATA(SDNEXT)
WRITE !,?10,"'B' TO ENTER THE MAKE APPT ROUTINES AND BOOK THE APPOINTMENTS"
+1 WRITE !,?10,"'C' TO LOOK FOR THE NEXT DATE ALL CLINICS HAVE AN AVAILABLE TIME SLOT",!,?10,"'R' TO REDISPLAY THIS SAME SCREEN"
QUIT
+2 ;
DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
+1 ;
BOOK DO STARS
+1 FOR G1=0:0
SET G1=$ORDER(SDC(G1))
if G1'>0
QUIT
WRITE !!,"Make appt in : ",$PIECE(SDC(G1),"^",2),!
SET SC=+SDC(G1)
DO S2
DO S3
DO TM
if SDMADE
DO MADE
if 'SDMADE
DO NOT
+2 KILL COLLAT
GOTO END^SDMULT0
MADE WRITE !!,$PIECE(^SC(+SDC(G1),"S",SD,1,SDY,0),"^",2)," minute appointment made in ",$PIECE(SDC(G1),"^",2),!
DO STARS
+1 QUIT
NOT WRITE !!,"No appt made in ",$PIECE(SDC1(SC),"^"),!
DO STARS
+1 QUIT
STARS SET SD0=""
SET $PIECE(SD0,"*",81)=""
WRITE !,SD0
KILL SD0
QUIT
TM SET SDMADE=0
READ !!,"SCHEDULE TIME: ",X:DTIME
if "^"[X!'($TEST)
QUIT
IF X?.E1"?"!(X'?1N.N)
WRITE !,"Enter the appointment time for this clinic"
GOTO TM
+1 SET X=$EXTRACT(SDAPP,4,7)_$EXTRACT(SDAPP,2,3)_"@"_X
SET %DT="TE"
DO ^%DT
IF Y<0
WRITE *7," WHEN ??"
GOTO TM
+2 KILL %DT
SET X=Y#1
SET Y=+Y
IF $DATA(^DPT(DFN,"S",Y,0))
IF $PIECE(^(0),"^",2)'["C"
SET Y1=+^(0)
SET Y1=$PIECE(^SC(+Y1,0),"^")
WRITE !,*7,"Patient already has an appointment in ",Y1," at that time"
KILL Y1
GOTO TM
+3 if $PIECE(SL,"^",2)]""
SET $PIECE(SL,"^")=$PIECE(SDC1(SC),"^",2)
SET SDMLT=1
KILL SDAPTYP
DO EN1^SDM1
+4 if 'SDMADE!(SDMADE=2)
GOTO TM
QUIT
S2 SET SL=^SC(SC,"SL")
SET X=$PIECE(SL,"^",3)
SET STARTDAY=$SELECT($LENGTH(X):X,1:8)
SET X=$PIECE(SL,"^",6)
SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)
QUIT
S3 WRITE !,LINE(G1),!,LINE1(G1)
+1 SET SB=STARTDAY-1/100
SET X=$PIECE(SL,U,6)
SET HSI=$SELECT(X=1:X,X:X,1:4)
SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)
SET SM=0
+2 KILL MXOK
SET SD=SDAPP
SET (CCX,CCXN,DP)=""
+3 QUIT
