SDB0 ;FLA/RF,BSN/GRR,ALB/LDB - PATTERN VALIDATION FOR CLINIC; 11 FEB 88@1200
;;5.3;Scheduling;**1015,1016**;Aug 13, 1993;Build 20
;IHS/ANMC/LJF 11/30/2000 changed $N to $O
; 12/08/2000 allowed schedule to fit on wide screen
; added code to accept scheduling templates
;
EN1 S SLT=+SL,HSI=SI
S:SI=1 SI=4,HSI=1 S:SI=2 SI=4,HSI=2
W !!?37,$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAY",! S (STIME,LT)=STARTDAY*100,CNT=0,D0=SD
NEW BSDTIME,BSDSLOT ;IHS/ANMC/LJF 12/08/2000
G2 ;R !!?2,"TIME: ",X:DTIME G:X="" G5 G:X["^"&('CNT) G1^SDB I X'?4N1"-"4N W " [ LIKE 0800-1200 ]" G G2 ;IHS/ANMC/LJF 12/08/2000
I $D(BSDTIME),BSDTIME="" G G5 ;IHS/ANMC/LJF 12/08/2000
I '$D(BSDTIME) S BSDTIME="" D ASK^BSDB0 ;IHS/ANMC/LJF 12/08/2000
S X=$P(BSDTIME,U),BSDTIME=$P(BSDTIME,U,2,99) ;IHS/ANMC/LJF 12/08/2000
G:X="" G5 I (X=U)&('CNT) G G1^SDB ;IHS/ANMC/LJF 12/08/2000
;
S T1=$P(X,"-",1),T2=$P(X,"-",2)
S SD1=$E(T1,3,4) I SD1>59!(T1>2400) D WMIL G G2
I SD1\5*5'=+SD1 D W5 G G2
S SD1=$E(T2,3,4) I SD1>59!(T2>2400) D WMIL G G2
I SD1\5*5'=+SD1 D W5 G G2
I T1<STIME W " [ CANNOT BE EARLIER THAN CLINIC START TIME ]" G G2
I T1<LT W " [ MUST BEGIN AFTER LAST ENDING TIME ]" G G2
I T2'>T1 W " [ MUST END AFTER BEGIN TIME ]" G G2
S H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4) F SDCL="M1","M2" S:@SDCL=0 @SDCL=60
S:M2=60 H2=H2-1 S:M1=60 H1=H1-1 S SD1=M2-M1+((H2-H1)*60),SDL=SD1\SLT I SDL*SLT'=+SD1 W " [ TIME SPAN ENTERED NOT CONSISTENT WITH ",SLT," MIN APPT LENGTH ]" G G2
K SD1
G3 ;R " NO. SLOTS: 1// ",NSL:DTIME S:NSL="" NSL=1 G:NSL["^" G2 I NSL'?1N.N W *7," ??" G G3 ;IHS/ANMC/LJF 12/08/2000
I '$D(BSDSLOT) R " NO. SLOTS: 1// ",NSL:DTIME S:NSL="" NSL=1 G:NSL["^" G2 I NSL'?1N.N W *7," ??" G G3 ;IHS/ANMC/LJF 12/08/2000
I $D(BSDSLOT) S NSL=$P(BSDSLOT,U),BSDSLOT=$P(BSDSLOT,U,2,99) ;IHS/ANMC/LJF 12/08/2000
S LT=T2,H1=$E(T1,1,2),H2=$E(T2,1,2),M1=$E(T1,3,4),M2=$E(T2,3,4)
S M2=M2-SLT
G3A I M2<0 S M2=M2+60,H2=H2-1 G G3A
S:M2?1N M2="0"_M2 S:H2?1N H2="0"_H2
G4 S CNT=CNT+1,^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_+$G(NSL) ;ihs/cmi/maw try for patch 1016 $S($G(NSL):NSL,1:1)
S M1=M1+SLT
G4A I M1>59 S M1=M1-60,H1=H1+1 G G4A
S:M1?1N M1="0"_M1 S:H1?1N H1="0"_H1
I (H1_M1)>(H2_M2) G G2
G G4
G5 G:'CNT DEL1^SDB1:'$D(SDREACT),DEL1^SDB1:'$D(SDTOP)&$D(SDREACT)&'CNT,C^SDB S ^SC(DA,"T",D0,0)=D0,^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
S X=^SC(DA,"T",0),^(0)="^44.002D^"_D0_"^"_($P(X,"^",4)+1)
S DH=SL*SI\60
;F ZDX=CNT:0 S ZDX=$N(^SC(DA,"T",D0,2,ZDX)) Q:ZDX<0 K ^SC(DA,"T",D0,2,ZDX) ;IHS/ANMC/LJF 11/30/2000
F ZDX=CNT:0 S ZDX=$O(^SC(DA,"T",D0,2,ZDX)) Q:ZDX="" K ^SC(DA,"T",D0,2,ZDX) ;IHS/ANMC/LJF 11/30/2000 $N->$O
;F X=0:0 S X=$N(^SC(DA,"T",D0,2,X)) Q:X'>0 S Y=^(X,0) F D=1:1:DH S Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$S($P(Y,U,2):$E("123456789jklmnopqrstuvwxyz",$P(Y,U,2)),1:0) ;IHS/ANMC/LJF 11/30/2000
F X=0:0 S X=$O(^SC(DA,"T",D0,2,X)) Q:X'>0 S Y=^(X,0) F D=1:1:DH S Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$S($P(Y,U,2):$E("123456789jklmnopqrstuvwxyz",$P(Y,U,2)),1:0) ;IHS/ANMC/LJF 11/30/2000 $N->$O
S (DH,DO,X)="" I $D(Y)=1 W *7,!,"DELETE " S SDEL=1 G D^SDB1
I $D(HSI) I HSI=1!(HSI=2) D CKSI1
;F Y=1:1 S DH=$D(Y(Y)),X=X_$S('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$S(DH:Y(Y),1:" "),DO=DH I 'DH,$N(Y(Y))<0 Q ;IHS/ANMC/LJF 11/30/2000
F Y=1:1 S DH=$D(Y(Y)),X=X_$S('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$S(DH:Y(Y),1:" "),DO=DH I 'DH,$O(Y(Y))="" Q ;IHS/ANMC/LJF 11/30/2000 $N->$O
;K Y W !,X,!,"...PATTERN " I SI+SI+$L(X)>80 W *7,"TOO WIDE TO FIT ON 80-CHAR SCREEN!" K ^SC(DA,"T",D0) S CNT=0,LT=STIME,SDEL=0 G G2 ;IHS/ANMC/LJF 12/08/2000
K Y W !,X,!,"...PATTERN " I SI+SI+$L(X)>132 W *7,"TOO WIDE TO FIT ON THE SCREEN!" K ^SC(DA,"T",D0) S CNT=0,LT=STIME,SDEL=0 G G2 ;IHS/ANMC/LJF 12/08/2000
W "OK FOR " G D^SDB1
CKSI1 ;F SDJJ=$N(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$N(Y(SDJJ))'>0 S SDJJ=$N(Y(SDJJ-1))-$S(HSI=1:4,1:2) ;IHS/ANMC/LJF 11/30/2000
;7/18/02 WAR - REMd next line and changed code per LJF17
;F SDJJ=$O(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$O(Y(SDJJ))="" S SDJJ=$O(Y(SDJJ-1))-$S(HSI=1:4,1:2) ;IHS/ANMC/LJF 11/30/2000 $N->$O
F SDJJ=$O(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>65 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$O(Y(SDJJ))="" S SDJJ=$O(Y(SDJJ-1))-$S(HSI=1:4,1:2) ;IHS/ANMC/LJF 11/30/2000 41->65
;F HHY=0:0 S HHY=$N(Y(HHY)) Q:HHY<0 I '$D(HY(HHY)) K Y(HHY) ;IHS/ANMC/LJF 11/30/2000
F HHY=0:0 S HHY=$O(Y(HHY)) Q:HHY="" I '$D(HY(HHY)) K Y(HHY) ;IHS/ANMC/LJF 11/30/2000 $N->$O
Q
W5 W " [ MUST SCHEDULE APPTS ON 5 MIN BOUNDARIES ]" Q
WMIL W " [ MUST ENTER VALID MILITARY TIME FORMATS ]" Q
SDB0 ;FLA/RF,BSN/GRR,ALB/LDB - PATTERN VALIDATION FOR CLINIC; 11 FEB 88@1200
+1 ;;5.3;Scheduling;**1015,1016**;Aug 13, 1993;Build 20
+2 ;IHS/ANMC/LJF 11/30/2000 changed $N to $O
+3 ; 12/08/2000 allowed schedule to fit on wide screen
+4 ; added code to accept scheduling templates
+5 ;
EN1 SET SLT=+SL
SET HSI=SI
+1 IF SI=1
SET SI=4
SET HSI=1
IF SI=2
SET SI=4
SET HSI=2
+2 WRITE !!?37,$PIECE("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,DOW+1),"DAY",!
SET (STIME,LT)=STARTDAY*100
SET CNT=0
SET D0=SD
+3 ;IHS/ANMC/LJF 12/08/2000
NEW BSDTIME,BSDSLOT
G2 ;R !!?2,"TIME: ",X:DTIME G:X="" G5 G:X["^"&('CNT) G1^SDB I X'?4N1"-"4N W " [ LIKE 0800-1200 ]" G G2 ;IHS/ANMC/LJF 12/08/2000
+1 ;IHS/ANMC/LJF 12/08/2000
IF $DATA(BSDTIME)
IF BSDTIME=""
GOTO G5
+2 ;IHS/ANMC/LJF 12/08/2000
IF '$DATA(BSDTIME)
SET BSDTIME=""
DO ASK^BSDB0
+3 ;IHS/ANMC/LJF 12/08/2000
SET X=$PIECE(BSDTIME,U)
SET BSDTIME=$PIECE(BSDTIME,U,2,99)
+4 ;IHS/ANMC/LJF 12/08/2000
IF X=""
GOTO G5
IF (X=U)&('CNT)
GOTO G1^SDB
+5 ;
+6 SET T1=$PIECE(X,"-",1)
SET T2=$PIECE(X,"-",2)
+7 SET SD1=$EXTRACT(T1,3,4)
IF SD1>59!(T1>2400)
DO WMIL
GOTO G2
+8 IF SD1\5*5'=+SD1
DO W5
GOTO G2
+9 SET SD1=$EXTRACT(T2,3,4)
IF SD1>59!(T2>2400)
DO WMIL
GOTO G2
+10 IF SD1\5*5'=+SD1
DO W5
GOTO G2
+11 IF T1<STIME
WRITE " [ CANNOT BE EARLIER THAN CLINIC START TIME ]"
GOTO G2
+12 IF T1<LT
WRITE " [ MUST BEGIN AFTER LAST ENDING TIME ]"
GOTO G2
+13 IF T2'>T1
WRITE " [ MUST END AFTER BEGIN TIME ]"
GOTO G2
+14 SET H1=$EXTRACT(T1,1,2)
SET H2=$EXTRACT(T2,1,2)
SET M1=$EXTRACT(T1,3,4)
SET M2=$EXTRACT(T2,3,4)
FOR SDCL="M1","M2"
IF @SDCL=0
SET @SDCL=60
+15 IF M2=60
SET H2=H2-1
IF M1=60
SET H1=H1-1
SET SD1=M2-M1+((H2-H1)*60)
SET SDL=SD1\SLT
IF SDL*SLT'=+SD1
WRITE " [ TIME SPAN ENTERED NOT CONSISTENT WITH ",SLT," MIN APPT LENGTH ]"
GOTO G2
+16 KILL SD1
G3 ;R " NO. SLOTS: 1// ",NSL:DTIME S:NSL="" NSL=1 G:NSL["^" G2 I NSL'?1N.N W *7," ??" G G3 ;IHS/ANMC/LJF 12/08/2000
+1 ;IHS/ANMC/LJF 12/08/2000
IF '$DATA(BSDSLOT)
READ " NO. SLOTS: 1// ",NSL:DTIME
IF NSL=""
SET NSL=1
IF NSL["^"
GOTO G2
IF NSL'?1N.N
WRITE *7," ??"
GOTO G3
+2 ;IHS/ANMC/LJF 12/08/2000
IF $DATA(BSDSLOT)
SET NSL=$PIECE(BSDSLOT,U)
SET BSDSLOT=$PIECE(BSDSLOT,U,2,99)
+3 SET LT=T2
SET H1=$EXTRACT(T1,1,2)
SET H2=$EXTRACT(T2,1,2)
SET M1=$EXTRACT(T1,3,4)
SET M2=$EXTRACT(T2,3,4)
+4 SET M2=M2-SLT
G3A IF M2<0
SET M2=M2+60
SET H2=H2-1
GOTO G3A
+1 IF M2?1N
SET M2="0"_M2
IF H2?1N
SET H2="0"_H2
G4 ;ihs/cmi/maw try for patch 1016 $S($G(NSL):NSL,1:1)
SET CNT=CNT+1
SET ^SC(DA,"T",D0,2,CNT,0)=H1_M1_"^"_+$GET(NSL)
+1 SET M1=M1+SLT
G4A IF M1>59
SET M1=M1-60
SET H1=H1+1
GOTO G4A
+1 IF M1?1N
SET M1="0"_M1
IF H1?1N
SET H1="0"_H1
+2 IF (H1_M1)>(H2_M2)
GOTO G2
+3 GOTO G4
G5 IF 'CNT
IF '$DATA(SDREACT)
GOTO DEL1^SDB1
IF '$DATA(SDTOP)&$DATA(SDREACT)&'CNT
GOTO DEL1^SDB1
GOTO C^SDB
SET ^SC(DA,"T",D0,0)=D0
SET ^SC(DA,"T",D0,2,0)="^44.004A^"_CNT_"^"_CNT
+1 SET X=^SC(DA,"T",0)
SET ^(0)="^44.002D^"_D0_"^"_($PIECE(X,"^",4)+1)
+2 SET DH=SL*SI\60
+3 ;F ZDX=CNT:0 S ZDX=$N(^SC(DA,"T",D0,2,ZDX)) Q:ZDX<0 K ^SC(DA,"T",D0,2,ZDX) ;IHS/ANMC/LJF 11/30/2000
+4 ;IHS/ANMC/LJF 11/30/2000 $N->$O
FOR ZDX=CNT:0
SET ZDX=$ORDER(^SC(DA,"T",D0,2,ZDX))
IF ZDX=""
QUIT
KILL ^SC(DA,"T",D0,2,ZDX)
+5 ;F X=0:0 S X=$N(^SC(DA,"T",D0,2,X)) Q:X'>0 S Y=^(X,0) F D=1:1:DH S Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$S($P(Y,U,2):$E("123456789jklmnopqrstuvwxyz",$P(Y,U,2)),1:0) ;IHS/ANMC/LJF 11/30/2000
+6 ;IHS/ANMC/LJF 11/30/2000 $N->$O
FOR X=0:0
SET X=$ORDER(^SC(DA,"T",D0,2,X))
IF X'>0
QUIT
SET Y=^(X,0)
FOR D=1:1:DH
SET Y(Y#100*SI\60+(Y\100*SI)-(STARTDAY*SI)+D)=$SELECT($PIECE(Y,U,2):$EXTRACT("123456789jklmnopqrstuvwxyz",$PIECE(Y,U,2)),1:0)
+7 SET (DH,DO,X)=""
IF $DATA(Y)=1
WRITE *7,!,"DELETE "
SET SDEL=1
GOTO D^SDB1
+8 IF $DATA(HSI)
IF HSI=1!(HSI=2)
DO CKSI1
+9 ;F Y=1:1 S DH=$D(Y(Y)),X=X_$S('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$S(DH:Y(Y),1:" "),DO=DH I 'DH,$N(Y(Y))<0 Q ;IHS/ANMC/LJF 11/30/2000
+10 ;IHS/ANMC/LJF 11/30/2000 $N->$O
FOR Y=1:1
SET DH=$DATA(Y(Y))
SET X=X_$SELECT('DH&DO:"]",'DO&DH:"[",Y#SI=1:"|",1:" ")_$SELECT(DH:Y(Y),1:" ")
SET DO=DH
IF 'DH
IF $ORDER(Y(Y))=""
QUIT
+11 ;K Y W !,X,!,"...PATTERN " I SI+SI+$L(X)>80 W *7,"TOO WIDE TO FIT ON 80-CHAR SCREEN!" K ^SC(DA,"T",D0) S CNT=0,LT=STIME,SDEL=0 G G2 ;IHS/ANMC/LJF 12/08/2000
+12 ;IHS/ANMC/LJF 12/08/2000
KILL Y
WRITE !,X,!,"...PATTERN "
IF SI+SI+$LENGTH(X)>132
WRITE *7,"TOO WIDE TO FIT ON THE SCREEN!"
KILL ^SC(DA,"T",D0)
SET CNT=0
SET LT=STIME
SET SDEL=0
GOTO G2
+13 WRITE "OK FOR "
GOTO D^SDB1
CKSI1 ;F SDJJ=$N(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$N(Y(SDJJ))'>0 S SDJJ=$N(Y(SDJJ-1))-$S(HSI=1:4,1:2) ;IHS/ANMC/LJF 11/30/2000
+1 ;7/18/02 WAR - REMd next line and changed code per LJF17
+2 ;F SDJJ=$O(Y(-1)):$S(HSI=1:4,1:2) Q:SDJJ>41 S:$D(Y(SDJJ)) HY(SDJJ)="" I '$D(Y(SDJJ)) Q:$O(Y(SDJJ))="" S SDJJ=$O(Y(SDJJ-1))-$S(HSI=1:4,1:2) ;IHS/ANMC/LJF 11/30/2000 $N->$O
+3 ;IHS/ANMC/LJF 11/30/2000 41->65
FOR SDJJ=$ORDER(Y(-1)):$SELECT(HSI=1:4,1:2)
IF SDJJ>65
QUIT
IF $DATA(Y(SDJJ))
SET HY(SDJJ)=""
IF '$DATA(Y(SDJJ))
IF $ORDER(Y(SDJJ))=""
QUIT
SET SDJJ=$ORDER(Y(SDJJ-1))-$SELECT(HSI=1:4,1:2)
+4 ;F HHY=0:0 S HHY=$N(Y(HHY)) Q:HHY<0 I '$D(HY(HHY)) K Y(HHY) ;IHS/ANMC/LJF 11/30/2000
+5 ;IHS/ANMC/LJF 11/30/2000 $N->$O
FOR HHY=0:0
SET HHY=$ORDER(Y(HHY))
IF HHY=""
QUIT
IF '$DATA(HY(HHY))
KILL Y(HHY)
+6 QUIT
W5 WRITE " [ MUST SCHEDULE APPTS ON 5 MIN BOUNDARIES ]"
QUIT
WMIL WRITE " [ MUST ENTER VALID MILITARY TIME FORMATS ]"
QUIT
