- 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 Mar 13, 2025@21:46:58 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
