DDGF4.m

DDGF4 ;SFISC/MKO-ACTIONS AFTER BLOCK SELECTION ;02:49 PM  12 Oct 1994

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;Input:

 ;  B     = Block number

 ;  C     = Block name

 ;  C1    = Block $Y

 ;  C2    = Block $X1

 ;  C3    = Block $X2

 ;  DDGFHDR = 1, if block is immobile (header block)

 ;

 N DDGFE

 S:'$G(DDGFHDR) DDGFHDR=0

 D PAINTS

 ;

 S DDGFE=0 F  S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y Q:DDGFE

 D CLEANUP

 Q

 ;

LNU Q:C1'>$P(DDGFLIM,U)!DDGFHDR

 D REDRAW

 S C1=C1-1,DY=DY-1

 D PAINTS

 Q

LND Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR

 D REDRAW

 S C1=C1+1,DY=DY+1

 D PAINTS

 Q

CHR Q:C2'<$P(DDGFLIM,U,4)!DDGFHDR

 D REDRAW

 S C2=C2+1,DX=DX+1

 D PAINTS

 Q

CHL Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR

 D REDRAW

 S C2=C2-1,DX=DX-1

 D PAINTS

 Q

TBR N X

 Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR

 D REDRAW

 S X=$$MIN(5,$P(DDGFLIM,U,4)-C2-$L(C)+1)

 S C2=C2+X,DX=DX+X

 D PAINTS

 Q

TBL N X

 Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR

 D REDRAW

 S X=$$MIN(5,C2-$P(DDGFLIM,U,2))

 S C2=C2-X,DX=DX-X

 D PAINTS

 Q

SCT Q:C1'>$P(DDGFLIM,U)!DDGFHDR

 D REDRAW

 S (C1,DY)=$P(DDGFLIM,U)

 D PAINTS

 Q

SCB Q:C1'<$P(DDGFLIM,U,3)!DDGFHDR

 D REDRAW

 S (C1,DY)=$P(DDGFLIM,U,3)

 D PAINTS

 Q

SCR N X

 Q:C2+$L(C)>$P(DDGFLIM,U,4)!DDGFHDR

 D REDRAW

 S X=$P(DDGFLIM,U,4)-C2-$L(C)+1

 S C2=C2+X,DX=DX+X

 D PAINTS

 Q

SCL N X

 Q:C2'>$P(DDGFLIM,U,2)!DDGFHDR

 D REDRAW

 S X=C2-$P(DDGFLIM,U,2)

 S C2=C2-X,DX=DX-X

 D PAINTS

 Q

 ;

EDIT ;Edit block parameters

 G:'$G(DDGFHDR) EDIT^DDGFBK

 G EDIT^DDGFHBK

 ;

REORDER ;Reorder fields on block

 D EN^DDGFORD(B)

 Q

 ;

TO ;Time-out

 W $C(7)

 G DESELECT

 ;

DESELECT ;

 S DDGFE=1

 Q

 ;

CLEANUP ;

 I '$G(DDGFBDEL) D

 . S C3=C2+$L(C)-1

 . S @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1,DDGFCHG=1

 . S @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$S($G(DDGFHDR):"H",1:"")

 ;

 I '$G(DDGFEBV),'$G(DDGFBDEL) D

 . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2))

 . X IOXY

 K DDGFHDR,DDGFBDEL

 Q

 ;

RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor

 N S

 I DDGFR D

 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)

 . X IOXY W S_$J("",7-$L(S))

 S DY=DDGFY,DX=DDGFX X IOXY

 Q

 ;

REDRAW ;

 D REPAINT^DDGLIBW(DDGFWIDB,(C1-$P(DDGFLIM,U))_U_(C2-$P(DDGFLIM,U,2))_U_1_U_$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))

 Q

 ;

PAINTS ;

 N Y,X

 S Y=DY,X=DX

 S DY=C1,DX=C2 X IOXY

 W $P(DDGLVID,DDGLDEL,6)_$E(C,1,$$MIN($L(C),$P(DDGFLIM,U,4)-C2+1))_$P(DDGLVID,DDGLDEL,10)

 D RC(Y,X)

 Q

 ;

MIN(X,Y,Z) ;Return the minimum of two or three numbers

 N A

 S A=$S(X<Y:X,1:Y)

 Q:$G(Z)="" A

 Q $S(A<Z:A,1:Z)

 ;

READ() N S,Y

 F  R *Y:DTIME D C Q:Y'=-1

 Q Y

 ;

C I Y<0 S Y="TO" Q

 S S=""

C1 S S=S_$C(Y)

 I DDGF("SIN")'[(U_S) D  I Y=-1 W $C(7) Q

 . I $C(Y)'?1L S Y=-1 Q

 . S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDGF("SIN")'[(U_S_U) Y=-1

 ;

 I DDGF("SIN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("SOUT"),U,$L($P(DDGF("SIN"),U_S_U),U)) Q

 R *Y:5 G:Y'=-1 C1 W $C(7)

 Q

DDGF4     ;SFISC/MKO-ACTIONS AFTER BLOCK SELECTION ;02:49 PM  12 Oct 1994

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;Input:

 +4       ;  B     = Block number

 +5       ;  C     = Block name

 +6       ;  C1    = Block $Y

 +7       ;  C2    = Block $X1

 +8       ;  C3    = Block $X2

 +9       ;  DDGFHDR = 1, if block is immobile (header block)

 +10      ;

 +11       NEW DDGFE

 +12       IF '$GET(DDGFHDR)

               SET DDGFHDR=0

 +13       DO PAINTS

 +14      ;

 +15       SET DDGFE=0

           FOR 

               SET Y=$$READ

               IF $TEXT(@Y)=""

                   WRITE $CHAR(7)

               IF $TEXT(@Y)]""

                   DO @Y

               IF DDGFE

                   QUIT 

 +16       DO CLEANUP

 +17       QUIT 

 +18      ;

LNU        IF C1'>$PIECE(DDGFLIM,U)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET C1=C1-1

           SET DY=DY-1

 +3        DO PAINTS

 +4        QUIT 

LND        IF C1'<$PIECE(DDGFLIM,U,3)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET C1=C1+1

           SET DY=DY+1

 +3        DO PAINTS

 +4        QUIT 

CHR        IF C2'<$PIECE(DDGFLIM,U,4)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET C2=C2+1

           SET DX=DX+1

 +3        DO PAINTS

 +4        QUIT 

CHL        IF C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET C2=C2-1

           SET DX=DX-1

 +3        DO PAINTS

 +4        QUIT 

TBR        NEW X

 +1        IF C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)!DDGFHDR

               QUIT 

 +2        DO REDRAW

 +3        SET X=$$MIN(5,$PIECE(DDGFLIM,U,4)-C2-$LENGTH(C)+1)

 +4        SET C2=C2+X

           SET DX=DX+X

 +5        DO PAINTS

 +6        QUIT 

TBL        NEW X

 +1        IF C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR

               QUIT 

 +2        DO REDRAW

 +3        SET X=$$MIN(5,C2-$PIECE(DDGFLIM,U,2))

 +4        SET C2=C2-X

           SET DX=DX-X

 +5        DO PAINTS

 +6        QUIT 

SCT        IF C1'>$PIECE(DDGFLIM,U)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET (C1,DY)=$PIECE(DDGFLIM,U)

 +3        DO PAINTS

 +4        QUIT 

SCB        IF C1'<$PIECE(DDGFLIM,U,3)!DDGFHDR

               QUIT 

 +1        DO REDRAW

 +2        SET (C1,DY)=$PIECE(DDGFLIM,U,3)

 +3        DO PAINTS

 +4        QUIT 

SCR        NEW X

 +1        IF C2+$LENGTH(C)>$PIECE(DDGFLIM,U,4)!DDGFHDR

               QUIT 

 +2        DO REDRAW

 +3        SET X=$PIECE(DDGFLIM,U,4)-C2-$LENGTH(C)+1

 +4        SET C2=C2+X

           SET DX=DX+X

 +5        DO PAINTS

 +6        QUIT 

SCL        NEW X

 +1        IF C2'>$PIECE(DDGFLIM,U,2)!DDGFHDR

               QUIT 

 +2        DO REDRAW

 +3        SET X=C2-$PIECE(DDGFLIM,U,2)

 +4        SET C2=C2-X

           SET DX=DX-X

 +5        DO PAINTS

 +6        QUIT 

 +7       ;

EDIT      ;Edit block parameters

 +1        IF '$GET(DDGFHDR)

               GOTO EDIT^DDGFBK

 +2        GOTO EDIT^DDGFHBK

 +3       ;

REORDER   ;Reorder fields on block

 +1        DO EN^DDGFORD(B)

 +2        QUIT 

 +3       ;

TO        ;Time-out

 +1        WRITE $CHAR(7)

 +2        GOTO DESELECT

 +3       ;

DESELECT  ;

 +1        SET DDGFE=1

 +2        QUIT 

 +3       ;

CLEANUP   ;

 +1        IF '$GET(DDGFBDEL)

               Begin DoDot:1

 +2                SET C3=C2+$LENGTH(C)-1

 +3                SET @DDGFREF@("F",DDGFPG,B)=C1_U_C2_U_C3_U_C_U_1

                   SET DDGFCHG=1

 +4                SET @DDGFREF@("BKRC",DDGFWIDB,C1,C2,C3,B)=$SELECT($GET(DDGFHDR):"H",1:"")

               End DoDot:1

 +5       ;

 +6        IF '$GET(DDGFEBV)

               IF '$GET(DDGFBDEL)

                   Begin DoDot:1

 +7                    DO WRITE^DDGLIBW(DDGFWIDB,C,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2))

 +8                    XECUTE IOXY

                   End DoDot:1

 +9        KILL DDGFHDR,DDGFBDEL

 +10       QUIT 

 +11      ;

RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor

 +1        NEW S

 +2        IF DDGFR

               Begin DoDot:1

 +3                SET DY=IOSL-6

                   SET DX=IOM-9

                   SET S="R"_(DDGFY+1)_",C"_(DDGFX+1)

 +4                XECUTE IOXY

                   WRITE S_$JUSTIFY("",7-$LENGTH(S))

               End DoDot:1

 +5        SET DY=DDGFY

           SET DX=DDGFX

           XECUTE IOXY

 +6        QUIT 

 +7       ;

REDRAW    ;

 +1        DO REPAINT^DDGLIBW(DDGFWIDB,(C1-$PIECE(DDGFLIM,U))_U_(C2-$PIECE(DDGFLIM,U,2))_U_1_U_$$MIN($LENGTH(C),$PIECE(DDGFLIM,U,4)-C2+1))

 +2        QUIT 

 +3       ;

PAINTS    ;

 +1        NEW Y,X

 +2        SET Y=DY

           SET X=DX

 +3        SET DY=C1

           SET DX=C2

           XECUTE IOXY

 +4        WRITE $PIECE(DDGLVID,DDGLDEL,6)_$EXTRACT(C,1,$$MIN($LENGTH(C),$PIECE(DDGFLIM,U,4)-C2+1))_$PIECE(DDGLVID,DDGLDEL,10)

 +5        DO RC(Y,X)

 +6        QUIT 

 +7       ;

MIN(X,Y,Z) ;Return the minimum of two or three numbers

 +1        NEW A

 +2        SET A=$SELECT(X<Y:X,1:Y)

 +3        IF $GET(Z)=""

               QUIT A

 +4        QUIT $SELECT(A<Z:A,1:Z)

 +5       ;

READ()     NEW S,Y

 +1        FOR 

               READ *Y:DTIME

               DO C

               IF Y'=-1

                   QUIT 

 +2        QUIT Y

 +3       ;

C          IF Y<0

               SET Y="TO"

               QUIT 

 +1        SET S=""

C1         SET S=S_$CHAR(Y)

 +1        IF DDGF("SIN")'[(U_S)

               Begin DoDot:1

 +2                IF $CHAR(Y)'?1L

                       SET Y=-1

                       QUIT 

 +3                SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)

                   IF DDGF("SIN")'[(U_S_U)

                       SET Y=-1

               End DoDot:1

               IF Y=-1

                   WRITE $CHAR(7)

                   QUIT 

 +4       ;

 +5        IF DDGF("SIN")[(U_S_U)

               IF S'=$CHAR(27)

                   SET Y=$PIECE(DDGF("SOUT"),U,$LENGTH($PIECE(DDGF("SIN"),U_S_U),U))

                   QUIT 

 +6        READ *Y:5

           IF Y'=-1

               GOTO C1

           WRITE $CHAR(7)

 +7        QUIT