- BSDM0 ; IHS/ANMC/LJF - IHS MONTH-AT-A-GLANCE ; [ 01/15/2004 11:39 AM ]
- ;;5.3;PIMS;**1005**;MAY 28, 2004
- ;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future booking, Monday appt okay
- ;
- EN(BSDANS) ;EP; -- main entry point for month-at-a-glance list templates
- NEW VALMCNT,DIR,DIC
- ;BSDANS = answer to date to start display
- S VALMCC=1 ;1=screen mode, 0=scrolling mode
- D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BSDAM MONTH DISPLAY")
- Q
- ;
- HDR ;EP; -- header code
- F I=1:1:3 Q:'$D(^SC(+SC,"SI",I,0)) S VALMHDR(I)=^(0)
- S VALM("TM")=I+3 ;set top margin based on # lines of special instruc
- S VALM("LINES")=VALM("BM")-VALM("TM")+1 ;reset # lines on screen
- Q
- ;
- INIT ;EP; -- init variables and list array
- K ^TMP("BSDM0",$J),^TMP("BSDM",$J) S VALMCNT=0
- D GUIR^XBLM("DISP^BSDM0","^TMP(""BSDM0"",$J,")
- S X=0 F S X=$O(^TMP("BSDM0",$J,X)) Q:'X D
- . S VALMCNT=X
- . S ^TMP("BSDM",$J,X,0)=^TMP("BSDM0",$J,X)
- ;
- ; add legend to display to explain 1s, 0s, As, Bs, *s, etc.
- S VALMCNT=VALMCNT+1,^TMP("BSDM",$J,VALMCNT,0)="" ;extra line
- NEW BSDX D LEGEND^BSDU(.BSDX)
- S X=0 F S X=$O(BSDX(X)) Q:'X D
- . S VALMCNT=VALMCNT+1,^TMP("BSDM",$J,VALMCNT,0)=BSDX(X)
- ;
- K ^TMP("BSDM0",$J)
- Q
- ;
- HELP ;EP; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ;EP; -- exit code
- K ^TMP("BSDM",$J)
- S VALMNOFF=1 ;suppress form feed before next question
- Q
- ;
- EXPND ;EP; -- expand code
- Q
- ;
- PAUSE ; -- end of action pause
- D PAUSE^BDGF Q
- ;
- RESET ; -- update partition for return to list manager
- I $D(VALMQUIT) S VALMBCK="Q" Q
- D TERM^VALM0 S VALMBCK="R"
- D INIT,HDR Q
- ;
- RESET2 ; -- update partition without recreating display array
- I $D(VALMQUIT) S VALMBCK="Q" Q
- D TERM^VALM0 S VALMBCK="R" D HDR Q
- ;
- DISP ;EP; creates display lines
- ;lines below copied from D^SDM0 to DIFF^SDM0
- ;lines modified to handle longer days using BSD variables
- NEW BSDIOM,BSDTOT,BSDCNT
- S BSDIOM=150,BSDTOT=BSDIOM-15 ;used in place of 80 & 65 below
- S X=BSDANS ;answer passed from SDM0
- S BSDCNT=0 ;counts lines per month
- W ?36,$P(SC,U,2) S:$O(^SC(+SC,"T",0))>X X=+$O(^(0)) D DOW S I=Y+32,D=Y S SDXF=0 D WM I SDXF D WMH
- ;
- ;IHS/OIT/LJF 03/08/2006 PATCH 1005 reset max days if max<3 and going over weekend
- ;I '$G(SDMAX) S X2=$S($D(^SC(+SC,"SDP")):$P(^("SDP"),"^",2),1:365),X1=DT,SDT=X D C^%DTC S SDMAX=X,X=SDT
- I '$G(SDMAX) D
- . S X2=$P($G(^SC(+SC,"SDP")),U,2) S:X2="" X2=365
- . I $$DOW^XLFDT(DT)="Friday",X2<3 S X2=3
- . S X1=DT,SDT=X D C^%DTC S SDMAX=X,X=SDT
- ;IHS/OIT/LJF 03/08/2006 end of changes
- ;
- S I=$$FMDIFF^XLFDT(SDMAX,X) ;reset last day to max future booking
- X1 S X1=X\100_$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(X,4,5)) ;28
- W I '$D(^SC(+SC,"ST",X,1)) S Y=D#7 G L:'$D(J(Y)),H:$D(^HOLIDAY(X))&('SDSOH) S SS=+$O(^SC(+SC,"T"_Y,X)) G L:SS'>0,L:^(SS,1)="" S ^SC(+SC,"ST",$P(X,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(X,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(X,".")
- ;S SDAV=1 D:X>SM WM I $D(^SC(+SC,"ST",X,1)),^(1)["["!(^(1)["CANCELLED")!($D(^HOLIDAY(X))) W !,$E(^SC(+SC,"ST",X,1),1,BSDIOM) S:'$D(^HOLIDAY(X))&('SDAV) SDAV=1
- ;S SDHX=X,SDAV=1 D:X>SM WM I SDXF<2 D WMH
- S SDHX=X,SDAV=1 I X>SM D WM,WMH ;TEMP MOD
- I BSDCNT=15 D WMH ;add headings if lots of lines per month
- I $D(^SC(+SC,"ST",X,1)),^(1)["["!(^(1)["CANCELLED")!($D(^HOLIDAY(X))) W !,$E(^SC(+SC,"ST",X,1),1,BSDIOM) S:'$D(^HOLIDAY(X))&('SDAV) SDAV=1 S BSDCNT=BSDCNT+1
- ;I $Y>18 W ! Q ;using list manager, no need for screen control
- L S X=X+1,D=D+1
- I $D(SDINA),X>SDINA,SDRE>X!('SDRE) D:'SDAV NOAV S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,?8,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"") S Y=SDHY K SDHY Q:'SDRE D DIFF
- ;
- I ($$FMDIFF^XLFDT(SDMAX,X))<0 W ! D:'SDAV MNTH Q ;IHS/OIT/LJF 03/08/2006 PATCH 1005
- ;
- G W:X'>X1 S X2=X-X1 D C^%DTC
- I $D(SDINA),X>SDINA,SDRE>X!('SDRE) D:'SDAV NOAV S SDHY=Y,Y=SDINA D DTS^SDUTL W !,*7,?8,"Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"") S Y=SDHY K SDHY Q:'SDRE
- ;
- ;IHS/OIT/LJF 03/08/2006 PATCH 1005
- ;G X1:D<I W ! D:'SDAV MNTH Q
- I (($$FMDIFF^XLFDT(SDMAX,X))'<0) G X1
- W ! D:'SDAV MNTH Q
- ;end of PATCH 1005 changes
- ;
- NOAV W !,"No availability found between date chosen and inactivate date!" Q
- H S ^SC(+SC,"ST",X,1)=" "_$E(X,6,7)_" "_$P(^(X,0),U,2),^(0)=X G W
- ;
- WM W !?36 S Y=$E(X,1,5)_"00",SM=$S($E(X,4,5)[12:$E(X,1,3)+1_"01",1:$E(X,1,3)_$E(X,4,5)+1)_"00"
- S SDXF=SDXF+1 I $E(X,6,7)>20 D
- . S SDXD=$O(^SC(+SC,"ST",X-1)) Q:SDXD=""
- . I $E(SDXD,4,5)'=$E(X,4,5) S SDXF=0
- D:SDXF DT
- Q
- ;
- WMH ;Write month heading lines
- W !!," TIME",?SI+SI-1 F Y=STARTDAY:1:BSDTOT\(SI+SI)+STARTDAY W $E("|"_$S('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
- W !," DATE",?SI+SI-1,"|" K J F Y=0:1:6 I $D(^SC(+SC,"T"_Y)) S J(Y)=""
- F Y=1:1:BSDTOT\(SI+SI) W $J("|",SI+SI)
- S SDXF=2
- S BSDCNT=0 ;reset count after printing time headings
- Q
- ;
- DT W $$FMTE^XLFDT(Y) Q
- ;
- DOW S Y=$$DOW^XLFDT(X,1) Q
- ;
- MNTH W !," *** No availability found for one full calendar month",!," Search stopped at " S Y=X D DTS^SDUTL W Y," ***",! Q
- DIFF S X1=SDRE,X2=X D ^%DTC S D=D+X,X=SDRE,X1=X\100_28 Q
- ;
- DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
- BSDM0 ; IHS/ANMC/LJF - IHS MONTH-AT-A-GLANCE ; [ 01/15/2004 11:39 AM ]
- +1 ;;5.3;PIMS;**1005**;MAY 28, 2004
- +2 ;IHS/OIT/LJF 03/08/2006 PATCH 1005 if max days for future booking, Monday appt okay
- +3 ;
- EN(BSDANS) ;EP; -- main entry point for month-at-a-glance list templates
- +1 NEW VALMCNT,DIR,DIC
- +2 ;BSDANS = answer to date to start display
- +3 ;1=screen mode, 0=scrolling mode
- SET VALMCC=1
- +4 DO TERM^VALM0
- DO CLEAR^VALM1
- +5 DO EN^VALM("BSDAM MONTH DISPLAY")
- +6 QUIT
- +7 ;
- HDR ;EP; -- header code
- +1 FOR I=1:1:3
- IF '$DATA(^SC(+SC,"SI",I,0))
- QUIT
- SET VALMHDR(I)=^(0)
- +2 ;set top margin based on # lines of special instruc
- SET VALM("TM")=I+3
- +3 ;reset # lines on screen
- SET VALM("LINES")=VALM("BM")-VALM("TM")+1
- +4 QUIT
- +5 ;
- INIT ;EP; -- init variables and list array
- +1 KILL ^TMP("BSDM0",$JOB),^TMP("BSDM",$JOB)
- SET VALMCNT=0
- +2 DO GUIR^XBLM("DISP^BSDM0","^TMP(""BSDM0"",$J,")
- +3 SET X=0
- FOR
- SET X=$ORDER(^TMP("BSDM0",$JOB,X))
- IF 'X
- QUIT
- Begin DoDot:1
- +4 SET VALMCNT=X
- +5 SET ^TMP("BSDM",$JOB,X,0)=^TMP("BSDM0",$JOB,X)
- End DoDot:1
- +6 ;
- +7 ; add legend to display to explain 1s, 0s, As, Bs, *s, etc.
- +8 ;extra line
- SET VALMCNT=VALMCNT+1
- SET ^TMP("BSDM",$JOB,VALMCNT,0)=""
- +9 NEW BSDX
- DO LEGEND^BSDU(.BSDX)
- +10 SET X=0
- FOR
- SET X=$ORDER(BSDX(X))
- IF 'X
- QUIT
- Begin DoDot:1
- +11 SET VALMCNT=VALMCNT+1
- SET ^TMP("BSDM",$JOB,VALMCNT,0)=BSDX(X)
- End DoDot:1
- +12 ;
- +13 KILL ^TMP("BSDM0",$JOB)
- +14 QUIT
- +15 ;
- HELP ;EP; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ;EP; -- exit code
- +1 KILL ^TMP("BSDM",$JOB)
- +2 ;suppress form feed before next question
- SET VALMNOFF=1
- +3 QUIT
- +4 ;
- EXPND ;EP; -- expand code
- +1 QUIT
- +2 ;
- PAUSE ; -- end of action pause
- +1 DO PAUSE^BDGF
- QUIT
- +2 ;
- RESET ; -- update partition for return to list manager
- +1 IF $DATA(VALMQUIT)
- SET VALMBCK="Q"
- QUIT
- +2 DO TERM^VALM0
- SET VALMBCK="R"
- +3 DO INIT
- DO HDR
- QUIT
- +4 ;
- RESET2 ; -- update partition without recreating display array
- +1 IF $DATA(VALMQUIT)
- SET VALMBCK="Q"
- QUIT
- +2 DO TERM^VALM0
- SET VALMBCK="R"
- DO HDR
- QUIT
- +3 ;
- DISP ;EP; creates display lines
- +1 ;lines below copied from D^SDM0 to DIFF^SDM0
- +2 ;lines modified to handle longer days using BSD variables
- +3 NEW BSDIOM,BSDTOT,BSDCNT
- +4 ;used in place of 80 & 65 below
- SET BSDIOM=150
- SET BSDTOT=BSDIOM-15
- +5 ;answer passed from SDM0
- SET X=BSDANS
- +6 ;counts lines per month
- SET BSDCNT=0
- +7 WRITE ?36,$PIECE(SC,U,2)
- IF $ORDER(^SC(+SC,"T",0))>X
- SET X=+$ORDER(^(0))
- DO DOW
- SET I=Y+32
- SET D=Y
- SET SDXF=0
- DO WM
- IF SDXF
- DO WMH
- +8 ;
- +9 ;IHS/OIT/LJF 03/08/2006 PATCH 1005 reset max days if max<3 and going over weekend
- +10 ;I '$G(SDMAX) S X2=$S($D(^SC(+SC,"SDP")):$P(^("SDP"),"^",2),1:365),X1=DT,SDT=X D C^%DTC S SDMAX=X,X=SDT
- +11 IF '$GET(SDMAX)
- Begin DoDot:1
- +12 SET X2=$PIECE($GET(^SC(+SC,"SDP")),U,2)
- IF X2=""
- SET X2=365
- +13 IF $$DOW^XLFDT(DT)="Friday"
- IF X2<3
- SET X2=3
- +14 SET X1=DT
- SET SDT=X
- DO C^%DTC
- SET SDMAX=X
- SET X=SDT
- End DoDot:1
- +15 ;IHS/OIT/LJF 03/08/2006 end of changes
- +16 ;
- +17 ;reset last day to max future booking
- SET I=$$FMDIFF^XLFDT(SDMAX,X)
- X1 ;28
- SET X1=X\100_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,+$EXTRACT(X,4,5))
- W IF '$DATA(^SC(+SC,"ST",X,1))
- SET Y=D#7
- IF '$DATA(J(Y))
- GOTO L
- IF $DATA(^HOLIDAY(X))&('SDSOH)
- GOTO H
- SET SS=+$ORDER(^SC(+SC,"T"_Y,X))
- IF SS'>0
- GOTO L
- IF ^(SS,1)=""
- GOTO L
- SET ^SC(+SC,"ST",$PIECE(X,"."),1)=$EXTRACT($PIECE($TEXT(DAY),U,Y+2),1,2)_" "_$EXTRACT(X,6,7)_$JUSTIFY("",SI+SI-6)_^(1)
- SET ^(0)=$PIECE(X,".")
- +1 ;S SDAV=1 D:X>SM WM I $D(^SC(+SC,"ST",X,1)),^(1)["["!(^(1)["CANCELLED")!($D(^HOLIDAY(X))) W !,$E(^SC(+SC,"ST",X,1),1,BSDIOM) S:'$D(^HOLIDAY(X))&('SDAV) SDAV=1
- +2 ;S SDHX=X,SDAV=1 D:X>SM WM I SDXF<2 D WMH
- +3 ;TEMP MOD
- SET SDHX=X
- SET SDAV=1
- IF X>SM
- DO WM
- DO WMH
- +4 ;add headings if lots of lines per month
- IF BSDCNT=15
- DO WMH
- +5 IF $DATA(^SC(+SC,"ST",X,1))
- IF ^(1)["["!(^(1)["CANCELLED")!($DATA(^HOLIDAY(X)))
- WRITE !,$EXTRACT(^SC(+SC,"ST",X,1),1,BSDIOM)
- IF '$DATA(^HOLIDAY(X))&('SDAV)
- SET SDAV=1
- SET BSDCNT=BSDCNT+1
- +6 ;I $Y>18 W ! Q ;using list manager, no need for screen control
- L SET X=X+1
- SET D=D+1
- +1 IF $DATA(SDINA)
- IF X>SDINA
- IF SDRE>X!('SDRE)
- IF 'SDAV
- DO NOAV
- SET SDHY=Y
- SET Y=SDINA
- DO DTS^SDUTL
- WRITE !,*7,?8,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
- SET Y=SDRE
- IF Y
- DO DTS^SDUTL
- WRITE $SELECT(SDRE:" to "_Y,1:"")
- SET Y=SDHY
- KILL SDHY
- IF 'SDRE
- QUIT
- DO DIFF
- +2 ;
- +3 ;IHS/OIT/LJF 03/08/2006 PATCH 1005
- IF ($$FMDIFF^XLFDT(SDMAX,X))<0
- WRITE !
- IF 'SDAV
- DO MNTH
- QUIT
- +4 ;
- +5 IF X'>X1
- GOTO W
- SET X2=X-X1
- DO C^%DTC
- +6 IF $DATA(SDINA)
- IF X>SDINA
- IF SDRE>X!('SDRE)
- IF 'SDAV
- DO NOAV
- SET SDHY=Y
- SET Y=SDINA
- DO DTS^SDUTL
- WRITE !,*7,?8,"Clinic is inactive ",$SELECT(SDRE:"from ",1:"as of "),Y
- SET Y=SDRE
- IF Y
- DO DTS^SDUTL
- WRITE $SELECT(SDRE:" to "_Y,1:"")
- SET Y=SDHY
- KILL SDHY
- IF 'SDRE
- QUIT
- +7 ;
- +8 ;IHS/OIT/LJF 03/08/2006 PATCH 1005
- +9 ;G X1:D<I W ! D:'SDAV MNTH Q
- +10 IF (($$FMDIFF^XLFDT(SDMAX,X))'<0)
- GOTO X1
- +11 WRITE !
- IF 'SDAV
- DO MNTH
- QUIT
- +12 ;end of PATCH 1005 changes
- +13 ;
- NOAV WRITE !,"No availability found between date chosen and inactivate date!"
- QUIT
- H SET ^SC(+SC,"ST",X,1)=" "_$EXTRACT(X,6,7)_" "_$PIECE(^(X,0),U,2)
- SET ^(0)=X
- GOTO W
- +1 ;
- WM WRITE !?36
- SET Y=$EXTRACT(X,1,5)_"00"
- SET SM=$SELECT($EXTRACT(X,4,5)[12:$EXTRACT(X,1,3)+1_"01",1:$EXTRACT(X,1,3)_$EXTRACT(X,4,5)+1)_"00"
- +1 SET SDXF=SDXF+1
- IF $EXTRACT(X,6,7)>20
- Begin DoDot:1
- +2 SET SDXD=$ORDER(^SC(+SC,"ST",X-1))
- IF SDXD=""
- QUIT
- +3 IF $EXTRACT(SDXD,4,5)'=$EXTRACT(X,4,5)
- SET SDXF=0
- End DoDot:1
- +4 IF SDXF
- DO DT
- +5 QUIT
- +6 ;
- WMH ;Write month heading lines
- +1 WRITE !!," TIME",?SI+SI-1
- FOR Y=STARTDAY:1:BSDTOT\(SI+SI)+STARTDAY
- WRITE $EXTRACT("|"_$SELECT('Y:0,1:(Y-1#12+1))_" ",1,SI+SI)
- +2 WRITE !," DATE",?SI+SI-1,"|"
- KILL J
- FOR Y=0:1:6
- IF $DATA(^SC(+SC,"T"_Y))
- SET J(Y)=""
- +3 FOR Y=1:1:BSDTOT\(SI+SI)
- WRITE $JUSTIFY("|",SI+SI)
- +4 SET SDXF=2
- +5 ;reset count after printing time headings
- SET BSDCNT=0
- +6 QUIT
- +7 ;
- DT WRITE $$FMTE^XLFDT(Y)
- QUIT
- +1 ;
- DOW SET Y=$$DOW^XLFDT(X,1)
- QUIT
- +1 ;
- MNTH WRITE !," *** No availability found for one full calendar month",!," Search stopped at "
- SET Y=X
- DO DTS^SDUTL
- WRITE Y," ***",!
- QUIT
- DIFF SET X1=SDRE
- SET X2=X
- DO ^%DTC
- SET D=D+X
- SET X=SDRE
- SET X1=X\100_28
- QUIT
- +1 ;
- DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR