- 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
