DDGF3 ;SFISC/MKO-Block Viewer Page ;02:49 PM 12 Oct 1994
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;Variables used:
; DDGFBV = flag indicating we're on block viewer page
; DDGFORIG(B) = original $Y^original $X for all blocks that were
; selected, since they were potentially moved
; DDGFEBV = flag that can be set to exit block viewer page
; after a block has been selected
;
N DDGFE
S DDGFE=0,DDGFBV=1 K DDGFORIG,DDGFEBV
;
D PAINT,RC(DY,DX)
F S Y=$$READ W:$T(@Y)="" $C(7) D:$T(@Y)]"" @Y D:$D(DDGFMSG) MSG^DDGF() Q:DDGFE!$G(DDGFEBV)
D CLEANUP
Q
;
LNU I DY>$P(DDGFLIM,U) D RC(DY-1,DX)
Q
LND I DY<$P(DDGFLIM,U,3) D RC(DY+1,DX)
Q
CHR I DX<$P(DDGFLIM,U,4) D RC(DY,DX+1)
Q
CHL I DX>$P(DDGFLIM,U,2) D RC(DY,DX-1)
Q
ELR N Y,X
S Y=DY,X=DX
F D Q:Y=""!(X]"")
. S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X))
. S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y))
D:X]"" RC(Y,X)
Q
ELL N Y,X
S Y=DY,X=DX
F D Q:Y=""!(X]"")
. S X=$O(@DDGFREF@("BKRC",DDGFWIDB,Y,X),-1)
. S:X="" Y=$O(@DDGFREF@("BKRC",DDGFWIDB,Y),-1)
D:X]"" RC(Y,X)
Q
TBR I DX<$P(DDGFLIM,U,4) D
. D RC(DY,$S(DX+5'<$P(DDGFLIM,U,4):$P(DDGFLIM,U,4),1:DX+5))
E I DY<$P(DDGFLIM,U,3) D RC(DY+1,$P(DDGFLIM,U,2))
Q
TBL I DX>$P(DDGFLIM,U,2) D
. D RC(DY,$S(DX-5'>$P(DDGFLIM,U,2):$P(DDGFLIM,U,2),1:DX-5))
E I DY>$P(DDGFLIM,U) D RC(DY-1,$P(DDGFLIM,U,4))
Q
;
SCT I DY>$P(DDGFLIM,U) D RC($P(DDGFLIM,U),DX)
Q
SCB I DY<$P(DDGFLIM,U,3) D RC($P(DDGFLIM,U,3),DX)
Q
SCR I DX<$P(DDGFLIM,U,4) D RC(DY,$P(DDGFLIM,U,4))
Q
SCL I DX>$P(DDGFLIM,U,2) D RC(DY,$P(DDGFLIM,U,2))
Q
SELECT ;
Q:'$D(@DDGFREF@("BKRC",DDGFWIDB,DY))
G SELECT^DDGFBSEL
;
SAVE ;Save data
G SAVE^DDGFSV
;
BKADD ;Add a new block
G ADD^DDGFBK
;
HBKADD ;Add a header block
G ADD^DDGFHBK
;
HELP ;Invoke help screens
D ^DDGFH,REFRESH^DDGF,RC(DY,DX)
Q
;
TO W $C(7)
QUIT ;
EXIT ;
VIEW S DDGFE=1
Q
CLEANUP ;
S DDGFDY=DY,DDGFDX=DX
D CLOSE^DDGLIBW(DDGFWIDB,1)
I $D(DDGFORIG) D
. N A
. S A=$$AREA^DDGLIBW(DDGFWID)
. D DESTROY^DDGLIBW(DDGFWID,1)
. D CREATE^DDGLIBW(DDGFWID,A,$P(@DDGFREF@("F",DDGFPG),U,3)]"")
. D BLK^DDGFUPDB(.DDGFORIG)
E D OPEN^DDGLIBW(DDGFWID)
S DY=IOSL-6,DX=46 X IOXY W $J("",13)
S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"<PF1>Q=Quit <PF1>E=Exit <PF1>S=Save <PF1>V=Block Viewer <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
D RC(DDGFDY,DDGFDX)
K DDGFDY,DDGFDX,DDGFBV,DDGFEBV,DDGFORIG
Q
;
PAINT ;Paint block displayer window
N B,C,S,DY,DX
D CLOSE^DDGLIBW(DDGFWID,1)
S DY=IOSL-6,DX=46 X IOXY W "BLOCK VIEWER"
S DY=IOSL-1,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)_$P(DDGLVID,DDGLDEL)_"<PF1>V=Main Screen <PF1>H=Help"_$P(DDGLVID,DDGLDEL,10)
I $$EXIST^DDGLIBW(DDGFWIDB) D FOCUS^DDGLIBW(DDGFWIDB) Q
D CREATE^DDGLIBW(DDGFWIDB,$P(DDGFLIM,U,1,2)_U_($P(DDGFLIM,U,3)-$P(DDGFLIM,U,1)+1)_U_($P(DDGFLIM,U,4)-$P(DDGFLIM,U,2)+1),$P(@DDGFREF@("F",DDGFPG),U,3)]"")
S B="" F S B=$O(@DDGFREF@("F",DDGFPG,B)) Q:B="" D
. S C=@DDGFREF@("F",DDGFPG,B)
. S S=$P(C,U,4)
. S:$P(C,U,3)'<IOM S=$E(S,1,IOM-$P(C,U,2)-1)
. D WRITE^DDGLIBW(DDGFWIDB,S,$P(C,U)-$P(DDGFLIM,U),$P(C,U,2)-$P(DDGFLIM,U,2))
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
;
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("IN")'[(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("IN")'[(U_S_U) Y=-1
;
I DDGF("IN")[(U_S_U),S'=$C(27) S Y=$P(DDGF("OUT"),U,$L($P(DDGF("IN"),U_S_U),U)) Q
R *Y:5 G:Y'=-1 C1 W $C(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGF3 4031 printed Apr 09, 2024@21:50:30 Page 2
DDGF3 ;SFISC/MKO-Block Viewer Page ;02:49 PM 12 Oct 1994
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;Variables used:
+8 ; DDGFBV = flag indicating we're on block viewer page
+9 ; DDGFORIG(B) = original $Y^original $X for all blocks that were
+10 ; selected, since they were potentially moved
+11 ; DDGFEBV = flag that can be set to exit block viewer page
+12 ; after a block has been selected
+13 ;
+14 NEW DDGFE
+15 SET DDGFE=0
SET DDGFBV=1
KILL DDGFORIG,DDGFEBV
+16 ;
+17 DO PAINT
DO RC(DY,DX)
+18 FOR
SET Y=$$READ
if $TEXT(@Y)=""
WRITE $CHAR(7)
if $TEXT(@Y)]""
DO @Y
if $DATA(DDGFMSG)
DO MSG^DDGF()
if DDGFE!$GET(DDGFEBV)
QUIT
+19 DO CLEANUP
+20 QUIT
+21 ;
LNU IF DY>$PIECE(DDGFLIM,U)
DO RC(DY-1,DX)
+1 QUIT
LND IF DY<$PIECE(DDGFLIM,U,3)
DO RC(DY+1,DX)
+1 QUIT
CHR IF DX<$PIECE(DDGFLIM,U,4)
DO RC(DY,DX+1)
+1 QUIT
CHL IF DX>$PIECE(DDGFLIM,U,2)
DO RC(DY,DX-1)
+1 QUIT
ELR NEW Y,X
+1 SET Y=DY
SET X=DX
+2 FOR
Begin DoDot:1
+3 SET X=$ORDER(@DDGFREF@("BKRC",DDGFWIDB,Y,X))
+4 if X=""
SET Y=$ORDER(@DDGFREF@("BKRC",DDGFWIDB,Y))
End DoDot:1
if Y=""!(X]"")
QUIT
+5 if X]""
DO RC(Y,X)
+6 QUIT
ELL NEW Y,X
+1 SET Y=DY
SET X=DX
+2 FOR
Begin DoDot:1
+3 SET X=$ORDER(@DDGFREF@("BKRC",DDGFWIDB,Y,X),-1)
+4 if X=""
SET Y=$ORDER(@DDGFREF@("BKRC",DDGFWIDB,Y),-1)
End DoDot:1
if Y=""!(X]"")
QUIT
+5 if X]""
DO RC(Y,X)
+6 QUIT
TBR IF DX<$PIECE(DDGFLIM,U,4)
Begin DoDot:1
+1 DO RC(DY,$SELECT(DX+5'<$PIECE(DDGFLIM,U,4):$PIECE(DDGFLIM,U,4),1:DX+5))
End DoDot:1
+2 IF '$TEST
IF DY<$PIECE(DDGFLIM,U,3)
DO RC(DY+1,$PIECE(DDGFLIM,U,2))
+3 QUIT
TBL IF DX>$PIECE(DDGFLIM,U,2)
Begin DoDot:1
+1 DO RC(DY,$SELECT(DX-5'>$PIECE(DDGFLIM,U,2):$PIECE(DDGFLIM,U,2),1:DX-5))
End DoDot:1
+2 IF '$TEST
IF DY>$PIECE(DDGFLIM,U)
DO RC(DY-1,$PIECE(DDGFLIM,U,4))
+3 QUIT
+4 ;
SCT IF DY>$PIECE(DDGFLIM,U)
DO RC($PIECE(DDGFLIM,U),DX)
+1 QUIT
SCB IF DY<$PIECE(DDGFLIM,U,3)
DO RC($PIECE(DDGFLIM,U,3),DX)
+1 QUIT
SCR IF DX<$PIECE(DDGFLIM,U,4)
DO RC(DY,$PIECE(DDGFLIM,U,4))
+1 QUIT
SCL IF DX>$PIECE(DDGFLIM,U,2)
DO RC(DY,$PIECE(DDGFLIM,U,2))
+1 QUIT
SELECT ;
+1 if '$DATA(@DDGFREF@("BKRC",DDGFWIDB,DY))
QUIT
+2 GOTO SELECT^DDGFBSEL
+3 ;
SAVE ;Save data
+1 GOTO SAVE^DDGFSV
+2 ;
BKADD ;Add a new block
+1 GOTO ADD^DDGFBK
+2 ;
HBKADD ;Add a header block
+1 GOTO ADD^DDGFHBK
+2 ;
HELP ;Invoke help screens
+1 DO ^DDGFH
DO REFRESH^DDGF
DO RC(DY,DX)
+2 QUIT
+3 ;
TO WRITE $CHAR(7)
QUIT ;
EXIT ;
VIEW SET DDGFE=1
+1 QUIT
CLEANUP ;
+1 SET DDGFDY=DY
SET DDGFDX=DX
+2 DO CLOSE^DDGLIBW(DDGFWIDB,1)
+3 IF $DATA(DDGFORIG)
Begin DoDot:1
+4 NEW A
+5 SET A=$$AREA^DDGLIBW(DDGFWID)
+6 DO DESTROY^DDGLIBW(DDGFWID,1)
+7 DO CREATE^DDGLIBW(DDGFWID,A,$PIECE(@DDGFREF@("F",DDGFPG),U,3)]"")
+8 DO BLK^DDGFUPDB(.DDGFORIG)
End DoDot:1
+9 IF '$TEST
DO OPEN^DDGLIBW(DDGFWID)
+10 SET DY=IOSL-6
SET DX=46
XECUTE IOXY
WRITE $JUSTIFY("",13)
+11 SET DY=IOSL-1
SET DX=0
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)_$PIECE(DDGLVID,DDGLDEL)_"<PF1>Q=Quit <PF1>E=Exit <PF1>S=Save <PF1>V=Block Viewer <PF1>H=Help"_$PIECE(DDGLVID,DDGLDEL,10)
+12 DO RC(DDGFDY,DDGFDX)
+13 KILL DDGFDY,DDGFDX,DDGFBV,DDGFEBV,DDGFORIG
+14 QUIT
+15 ;
PAINT ;Paint block displayer window
+1 NEW B,C,S,DY,DX
+2 DO CLOSE^DDGLIBW(DDGFWID,1)
+3 SET DY=IOSL-6
SET DX=46
XECUTE IOXY
WRITE "BLOCK VIEWER"
+4 SET DY=IOSL-1
SET DX=0
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)_$PIECE(DDGLVID,DDGLDEL)_"<PF1>V=Main Screen <PF1>H=Help"_$PIECE(DDGLVID,DDGLDEL,10)
+5 IF $$EXIST^DDGLIBW(DDGFWIDB)
DO FOCUS^DDGLIBW(DDGFWIDB)
QUIT
+6 DO CREATE^DDGLIBW(DDGFWIDB,$PIECE(DDGFLIM,U,1,2)_U_($PIECE(DDGFLIM,U,3)-$PIECE(DDGFLIM,U,1)+1)_U_($PIECE(DDGFLIM,U,4)-$PIECE(DDGFLIM,U,2)+1),$PIECE(@DDGFREF@("F",DDGFPG),U,3)]"")
+7 SET B=""
FOR
SET B=$ORDER(@DDGFREF@("F",DDGFPG,B))
if B=""
QUIT
Begin DoDot:1
+8 SET C=@DDGFREF@("F",DDGFPG,B)
+9 SET S=$PIECE(C,U,4)
+10 if $PIECE(C,U,3)'<IOM
SET S=$EXTRACT(S,1,IOM-$PIECE(C,U,2)-1)
+11 DO WRITE^DDGLIBW(DDGFWIDB,S,$PIECE(C,U)-$PIECE(DDGFLIM,U),$PIECE(C,U,2)-$PIECE(DDGFLIM,U,2))
End DoDot:1
+12 QUIT
+13 ;
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 ;
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("IN")'[(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("IN")'[(U_S_U)
SET Y=-1
End DoDot:1
IF Y=-1
WRITE $CHAR(7)
QUIT
+4 ;
+5 IF DDGF("IN")[(U_S_U)
IF S'=$CHAR(27)
SET Y=$PIECE(DDGF("OUT"),U,$LENGTH($PIECE(DDGF("IN"),U_S_U),U))
QUIT
+6 READ *Y:5
if Y'=-1
GOTO C1
WRITE $CHAR(7)
+7 QUIT
