SDB1 ;ALB/GRR - SET UP A CLINIC ; 8/30/00 9:27am
;;5.3;PIMS;**20,183,221,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 12/08/2000 added call to IHS help text
;
;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'<DO)!(X'<(DT+50000)) I $D(^SC(DA,"ST",X,9)) S DR=X,SDSAV=0 G SM
K ^SC(DA,"ST",X) I DR<0,'$O(^(X)) Q
G X2:X+1<DR
S DR=+$O(^SC(DA,"S",X)),SDSAV=0 G X2:DR\1-X
SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) S:'SDSAV SDSAV=1,SDPAT=SM
I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1)
F Y=0:0 S Y=$O(^SC(DA,"S",DR,1,Y)) Q:Y'>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)=D,SDREACT=1 S:'$D(^SC(DA,"ST",0)) ^(0)="^44.005DA^^" D B1 ;SD*567 change set of 9 node to selected date
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 SDIN<D,SDRE,SDRE'>D K SDIN Q
I SDIN<D,SDRE=0 S POP=1 Q
I SDIN<D,SDRE>D 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 ;
D HELP1^BSDB G G1^SDB ;IHS/ANMC/LJF 12/08/2000
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
SDB1 ;ALB/GRR - SET UP A CLINIC ; 8/30/00 9:27am
+1 ;;5.3;PIMS;**20,183,221,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 12/08/2000 added call to IHS help text
+3 ;
+4 ;DH=PATTERN DO=EXPIRATION DATE X=START DATE
B1 SET DR=0
SET SB=STARTDAY-1/100
SET STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
SET SDONE=1
+1 NEW SDX,SDSL,SL,SI,SDSI,SDSOH,STARTDAY,HSI
SETX IF '$DATA(^SC(DA,"SL"))
QUIT
SET SDSL=^("SL")
SET SL=+^("SL")
SET SDX=$PIECE(SDSL,U,3)
SET STARTDAY=$SELECT($LENGTH(SDX):SDX,1:8)
SET SDX=$PIECE(SDSL,U,6)
SET HSI=$SELECT('SDX:4,SDX<3:8/SDX,1:2)
SET SI=$SELECT(SDX:SDX,1:4)
SET SDSI=SI
IF SI=1
SET SI=4
IF SI=2
SET SI=4
SET SDSOH=$SELECT($PIECE(SDSL,U,8)']"":0,1:1)
X IF X'>DO
IF $GET(^SC(DA,"ST",X,1))["**CANCELLED**"!($GET(^SC(DA,"ST",X,1))["X")
SET ^TMP("SDAVAIL",$JOB,X)=^(1)
+1 IF (X'<DO)!(X'<(DT+50000))
QUIT
IF $DATA(^SC(DA,"ST",X,9))
SET DR=X
SET SDSAV=0
GOTO SM
+2 KILL ^SC(DA,"ST",X)
IF DR<0
IF '$ORDER(^(X))
QUIT
+3 IF X+1<DR
GOTO X2
+4 SET DR=+$ORDER(^SC(DA,"S",X))
SET SDSAV=0
IF DR\1-X
GOTO X2
SM SET SM=$PIECE("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_DH_$JUSTIFY("",64-$LENGTH(DH))
IF 'SDSAV
SET SDSAV=1
SET SDPAT=SM
I SET I=DR#1-SB*100
SET I=I#1*SI\.6+(I\1*SI)*2
SET S=$EXTRACT(SM,I,999)
SET SM=$EXTRACT(SM,1,I-1)
+1 FOR Y=0:0
SET Y=$ORDER(^SC(DA,"S",DR,1,Y))
IF Y'>0
QUIT
IF $PIECE(^(Y,0),"^",9)'["C"
SET SDSL=$PIECE(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI
FOR I=0:HSI:SDSL
SET ST=$EXTRACT(S,I+2)
IF ST=""
SET ST=" "
SET S=$EXTRACT(S,1,I+2-1)_$EXTRACT(STR,$FIND(STR,ST)-2)_$EXTRACT(S,I+3,999)
DO OB
+2 SET SM=SM_S
SET DR=+$ORDER(^SC(DA,"S",DR))
IF DR\1=X
GOTO I
+3 IF $LENGTH(SM)>SM
SET ^SC(DA,"ST",X,0)=X
SET ^(1)=SM
IF '$DATA(^SC(DA,"ST",0))
SET ^(0)="^44.005DA^^"
IF $DATA(^SC(DA,"ST",X,9))
SET ^SC(DA,"OST",X,1)=SDPAT
SET ^(0)=X
IF '$DATA(^SC(DA,"OST",0))
SET ^(0)="^44.0002DA^^"
+4 FOR SDCAN=X:0
SET SDCAN=$ORDER(^SC(DA,"SDCAN",SDCAN))
IF (SDCAN\1-(X\1))!'SDCAN
QUIT
KILL ^(SDCAN)
X2 IF X#100<22
SET X=X+7
+1 IF '$TEST
SET X1=X
SET X2=7
DO C^%DTC
+2 GOTO X
+3 ;
DEL1 SET (DH,DO,X)=""
WRITE !,*7,*7,"DELETE "
SET SDEL=1
D IF $DATA(SDIN)
IF SDIN>D0
SET SDRE1=$SELECT(SDRE:SDRE,1:9999999)
+1 WRITE $PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAYS "
SET DH=X
SET OK=0
SET CTR=0
+2 SET SDSOH=$SELECT('$DATA(^SC(DA,"SL")):0,$PIECE(^("SL"),"^",8)']"":0,1:1)
+3 FOR X=D0:0
SET X=+$ORDER(^SC(DA,"T",X))
IF X'>0
QUIT
DO DOW^SDM0
IF Y=DOW
SET Y=X
SET DO=Y
WRITE "UNTIL "
DO DT^DIO2
GOTO R
+4 IF X'>0
IF $DATA(SDIN)
IF SDIN>D0
SET SDRE1=$SELECT(SDRE=0:9999999,1:SDRE)
SET X=SDIN
FOR I=0:1:6
DO DOW^SDM0
IF Y=DOW
SET OK=1
IF OK
QUIT
SET X1=X
SET X2=1
DO C^%DTC
IF X>SDRE1
QUIT
+5 IF OK
SET Y=X
SET DO=D0
WRITE " UNTIL "
DO DT^DIO2
GOTO R
+6 SET DO=9999999
WRITE "INDEFINITELY"
R KILL OK
SET %=""
DO YN^DICN
IF '%
WRITE !,"REPLY YES (Y) OR NO (N)"
GOTO R
EN1 SET D=D0
IF ((%-1)>0)
GOTO 1
IF %<0
GOTO G1^SDB
+1 SET Y=""
IF '$DATA(^SC(DA,"T"_DOW,D0,1))
SET Y=+$ORDER(^SC(DA,"T"_DOW,D0))
IF Y>D0
SET X=^(Y,1)
SET POP=0
DO CHK1
IF 'POP
KILL ^SC(DA,"T"_DOW,Y)
SET ^SC(DA,"T"_DOW,D0,1)=X
SET ^(0)=D0
DO TX
+2 IF Y<0
IF '$DATA(^SC(DA,"T"_DOW,D0))
SET ^(D0,1)=""
SET ^(0)=D0
DO TX
+3 SET ^SC(DA,"T"_DOW,DO,1)=DH
SET ^(0)=DO
DO TX
+4 SET X=D0
DO B1
SET MAX=30
SET SC=DA
SET SDSTRTDT=SD
IF 'CNT
GOTO G1^SDB
DO WAIT^DICD
DO OVR^SDAUT1
WRITE !,"PATTERN FILED!",!
IF 'SDZQ
QUIT
GOTO G1^SDB
+5 ;
1 IF SDEL
SET POP=0
DO APPCK
IF POP
DO DELERR
GOTO OVR
11 IF $DATA(^HOLIDAY(D,0))&('SDSOH)
GOTO OVR
SET POP=0
IF $DATA(SDIN)
DO CHK2
IF POP
GOTO OVR
WRITE !,"...FOR "
SET Y=D
DO DT^DIO2
SET %=2
DO YN^DICN
IF '%
WRITE !,"REPLY YES (Y) OR NO (N)"
GOTO 11
+1 IF (%<0)
GOTO G1^SDB
IF (%-1)
GOTO OVR
+2 SET (POP,SDREB)=0
DO APPCK
IF POP
DO APPERR
IF (%-1)
GOTO OVR
SET SDREB=1
+3 ;SD*567 change set of 9 node to selected date
WRITE " ...OK"
SET X=D
SET DO=X+1
SET ^SC(DA,"ST",X,9)=D
SET SDREACT=1
IF '$DATA(^SC(DA,"ST",0))
SET ^(0)="^44.005DA^^"
DO B1
OVR IF D#100<22
SET D=D+7
SET POP=0
IF $DATA(SDIN)
DO CHK2
IF POP=1
GOTO G1^SDB
GOTO 1
+1 SET X1=D
SET X2=7
DO C^%DTC
SET D=X
SET POP=0
IF $DATA(SDIN)
DO CHK2
IF POP=1
GOTO G1^SDB
GOTO 1
+2 ;
APPCK FOR A=D:0
SET A=+$ORDER(^SC(DA,"S",A))
IF A'>0!(A\1-D)
QUIT
FOR SDA1=0:0
SET SDA1=+$ORDER(^SC(DA,"S",A,1,SDA1))
IF SDA1'>0
QUIT
IF $PIECE(^SC(DA,"S",A,1,SDA1,0),"^",9)'["C"
SET POP=1
QUIT
+1 QUIT
APPERR WRITE *7,!,"THERE ARE ALREADY APPOINTMENTS PENDING ON THIS DATE",!,"ARE YOU SURE YOU WANT TO CHANGE THE EXISTING AVAILABILITY"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !,"IF YOU SAY YES, THE EXISTING APPOINTMENTS MAY BECOME OVERBOOKS WHEN THE NEW AVAILABILITY IS APPLIED",!,"ANSWER YES OR NO"
GOTO APPERR
+2 QUIT
DELERR SET Y=D
WRITE !,"... "
DO DT^DIQ
WRITE " HAS PENDING APPTS - DELETE AVAILABILITY NOT ALLOWED"
QUIT
CHK1 IF '$DATA(SDIN)
QUIT
+1 IF Y=SDIN
SET POP=1
+2 QUIT
+3 ;
CHK2 IF SDIN<D
IF SDRE
IF SDRE'>D
KILL SDIN
QUIT
+1 IF SDIN<D
IF SDRE=0
SET POP=1
QUIT
+2 IF SDIN<D
IF SDRE>D
SET POP=2
SET D=SDRE
SET X=D
FOR I=0:1:6
DO DOW^SDM0
IF Y=DOW
QUIT
SET X1=D
SET X2=1
DO C^%DTC
SET D=X
+3 SET Y=SDIN
DO DTS^SDUTL
SET Y1=Y
SET Y=SDRE1
DO DTS^SDUTL
IF POP=2&('CTR)
WRITE !!," Clinic is inactive from ",Y1," to ",Y,!
IF POP=2
SET CTR=1
+4 QUIT
OB SET SDSLOT=$EXTRACT(STR,$FIND(STR,ST)-2)
IF SDSLOT?1P
IF SDSLOT'?1" "
SET ^SC(DA,"S",DR,1,Y,"OB")="O"
KILL SDSLOT
QUIT
+1 KILL ^SC(DA,"S",DR,1,Y,"OB"),SDSLOT
QUIT
HLPD ;
+1 ;IHS/ANMC/LJF 12/08/2000
DO HELP1^BSDB
GOTO G1^SDB
+2 WRITE !,"ENTER THE DATE THIS CLINIC BECOMES AVAILABLE TO SEE PATIENTS"
+3 WRITE !,"THE DATE ENTERED WILL BE THE FIRST DATE THAT APPOINTMENTS CAN",!,"BE MADE FOR THIS CLINIC"
GOTO G1^SDB
TX IF '$DATA(^SC(DA,"T"_DOW,0))
SET ^(0)="^44.0"_$SELECT(DOW<4:DOW+6,DOW<6:"0"_DOW+4,1:"001")_"A^^"
QUIT
