SDB1 ;ALB/GRR - SET UP A CLINIC ; 8/30/00 9:27am ;;5.3;Scheduling;**20,183,221**;Aug 13, 1993 ;DH=PATTERN DO=EXPIRATION DATE X=START DATE B1 S DR=0,SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDONE=1 N SDX,SDSL,SL,SI,SDSI,SDSOH,STARTDAY,HSI SETX Q:'$D(^SC(DA,"SL")) S SDSL=^("SL"),SL=+^("SL"),SDX=$P(SDSL,U,3),STARTDAY=$S($L(SDX):SDX,1:8),SDX=$P(SDSL,U,6),HSI=$S('SDX:4,SDX<3:8/SDX,1:2),SI=$S(SDX:SDX,1:4),SDSI=SI S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) X I X'>DO,$G(^SC(DA,"ST",X,1))["**CANCELLED**"!($G(^SC(DA,"ST",X,1))["X") S ^TMP("SDAVAIL",$J,X)=^(1) Q:(X'0 I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999) D OB S SM=SM_S,DR=+$O(^SC(DA,"S",DR)) I DR\1=X G I I $L(SM)>SM S ^SC(DA,"ST",X,0)=X,^(1)=SM S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" I $D(^SC(DA,"ST",X,9)) S ^SC(DA,"OST",X,1)=SDPAT,^(0)=X S:'$D(^SC(DA,"OST",0)) ^(0)="^44.0002DA^^" F SDCAN=X:0 S SDCAN=$O(^SC(DA,"SDCAN",SDCAN)) Q:(SDCAN\1-(X\1))!'SDCAN K ^(SDCAN) X2 I X#100<22 S X=X+7 E S X1=X,X2=7 D C^%DTC G X ; DEL1 S (DH,DO,X)="" W !,*7,*7,"DELETE " S SDEL=1 D I $D(SDIN),SDIN>D0 S SDRE1=$S(SDRE:SDRE,1:9999999) W $P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAYS " S DH=X,OK=0,CTR=0 S SDSOH=$S('$D(^SC(DA,"SL")):0,$P(^("SL"),"^",8)']"":0,1:1) F X=D0:0 S X=+$O(^SC(DA,"T",X)) Q:X'>0 D DOW^SDM0 I Y=DOW S Y=X,DO=Y W "UNTIL " D DT^DIO2 G R I X'>0,$D(SDIN),SDIN>D0 S SDRE1=$S(SDRE=0:9999999,1:SDRE) S X=SDIN F I=0:1:6 D DOW^SDM0 S:Y=DOW OK=1 Q:OK S X1=X,X2=1 D C^%DTC Q:X>SDRE1 I OK S Y=X,DO=D0 W " UNTIL " D DT^DIO2 G R S DO=9999999 W "INDEFINITELY" R K OK S %="" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G R EN1 S D=D0 G 1:((%-1)>0),G1^SDB:%<0 S Y="" I '$D(^SC(DA,"T"_DOW,D0,1)) S Y=+$O(^SC(DA,"T"_DOW,D0)) I Y>D0 S X=^(Y,1),POP=0 D CHK1 K:'POP ^SC(DA,"T"_DOW,Y) S ^SC(DA,"T"_DOW,D0,1)=X,^(0)=D0 D TX I Y<0,'$D(^SC(DA,"T"_DOW,D0)) S ^(D0,1)="",^(0)=D0 D TX S ^SC(DA,"T"_DOW,DO,1)=DH,^(0)=DO D TX S X=D0 D B1 S MAX=30,SC=DA,SDSTRTDT=SD G:'CNT G1^SDB D WAIT^DICD,OVR^SDAUT1 W !,"PATTERN FILED!",! Q:'SDZQ G G1^SDB ; 1 I SDEL S POP=0 D APPCK I POP D DELERR G OVR 11 G:$D(^HOLIDAY(D,0))&('SDSOH) OVR S POP=0 D:$D(SDIN) CHK2 G:POP OVR W !,"...FOR " S Y=D D DT^DIO2 S %=2 D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G 11 G G1^SDB:(%<0) I (%-1) G OVR S (POP,SDREB)=0 D APPCK I POP D APPERR G:(%-1) OVR S SDREB=1 W " ...OK" S X=D,DO=X+1,^SC(DA,"ST",X,9)=DA,SDREACT=1 S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" D B1 OVR I D#100<22 S D=D+7 S POP=0 D:$D(SDIN) CHK2 G G1^SDB:POP=1,1 S X1=D,X2=7 D C^%DTC S D=X S POP=0 D:$D(SDIN) CHK2 G G1^SDB:POP=1,1 ; APPCK F A=D:0 S A=+$O(^SC(DA,"S",A)) Q:A'>0!(A\1-D) F SDA1=0:0 S SDA1=+$O(^SC(DA,"S",A,1,SDA1)) Q:SDA1'>0 I $P(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C" S POP=1 Q Q APPERR W *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY" S %=2 D YN^DICN I '% W !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO" G APPERR Q DELERR S Y=D W !,"... " D DT^DIQ W " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED" Q CHK1 Q:'$D(SDIN) I Y=SDIN S POP=1 Q ; CHK2 I SDIND K SDIN Q I SDIND S POP=2,D=SDRE,X=D F I=0:1:6 D DOW^SDM0 Q:Y=DOW S X1=D,X2=1 D C^%DTC S D=X S Y=SDIN D DTS^SDUTL S Y1=Y,Y=SDRE1 D DTS^SDUTL W:POP=2&('CTR) !!," Clinic is inactive from ",Y1," to ",Y,! S:POP=2 CTR=1 Q OB S SDSLOT=$E(STR,$F(STR,ST)-2) I SDSLOT?1P,SDSLOT'?1" " S ^SC(DA,"S",DR,1,Y,"OB")="O" K SDSLOT Q K ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT Q HLPD W !,"ENTER THE DATE THIS CLINIC BECOMES AVAILABLE TO SEE PATIENTS" W !,"THE DATE ENTERED WILL BE THE FIRST DATE THAT APPOINTMENTS CAN",!,"BE MADE FOR THIS CLINIC" G G1^SDB TX S:'$D(^SC(DA,"T"_DOW,0)) ^(0)="^44.0"_$S(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^" Q