DDGF1 ;SFISC/MKO-MAIN SCREEN ;02:46 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.
;
D RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
S DDGFE=0 F S Y=$$READ W:$T(@Y)="" $C(7) D:$D(DDGFMSG) MSG^DDGF() D:$T(@Y)]"" @Y Q:DDGFE
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
S X=$O(@DDGFREF@("RC",DDGFWID,Y,X))
D:X=""
. S Y=$O(@DDGFREF@("RC",DDGFWID,Y))
. S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""))
. S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,Y,""))
D:X]"" RC(Y,X)
Q
ELL N Y,X
S Y=DY,X=DX
S X=$O(@DDGFREF@("RC",DDGFWID,Y,X),-1)
D:X=""
. S Y=$O(@DDGFREF@("RC",DDGFWID,Y),-1)
. S:Y="" Y=$O(@DDGFREF@("RC",DDGFWID,""),-1)
. S:Y]"" X=$O(@DDGFREF@("RC",DDGFWID,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
;
SAVE ;Save data from DDGFREF
I 'DDGFPG D ERR(110) Q
G SAVE^DDGFSV
;
SELECT ;Select an item
I 'DDGFPG D ERR(110) Q
G SELECT^DDGFEL
;
EDIT ;Edit a caption or data length
I 'DDGFPG D ERR(110) Q
G EDIT^DDGFEL
;
FLDADD ;Add a new field to the form
I 'DDGFPG D ERR(110) Q
G ADD^DDGFFLDA
;
VIEW ;Go to block viewer
I 'DDGFPG D ERR(110) Q
I $O(@DDGFREF@("F",DDGFPG,""))="" D ERR(120) Q
G ^DDGF3
;
BKADD ;Add a new block
I 'DDGFPG D ERR(110) Q
G ADD^DDGFBK
;
HBKADD ;Add a header block
I 'DDGFPG D ERR(110) Q
G ADD^DDGFHBK
;
NXTPG ;Go to next page
I 'DDGFPG D ERR(110) Q
D NXTPRV^DDGFPG(1) Q
;
PRVPG ;Go to previous page
I 'DDGFPG D ERR(110) Q
D NXTPRV^DDGFPG(-1) Q
;
CLSPG ;Close pop-up page
G CLSPG^DDGFPG
;
PGSEL ;Select a new page
I 'DDGFPG D ERR(110) Q
G PGSEL^DDGFPG
;
PGADD ;Add a new page to the form
G ADD^DDGFPG
;
PGEDIT ;Edit attributes of a page
I 'DDGFPG D ERR(110) Q
G EDIT^DDGFPG
;
FMSEL ;Select another form
G SEL^DDGFFM
;
FMADD ;Add a new form
G ADD^DDGFFM
;
FMEDIT ;Edit the form
G EDIT^DDGFFM
;
HELP ;Invoke help screens
G HLP^DDGFH
;
TO ;Time-out
W $C(7)
G QUIT
;
QUIT ;Exit from form designer
I DDGLSCR>1 G CLSPG^DDGFPG
S DDGFE=1
Q
EXIT ;Save and exit
I DDGLSCR>1 G CLSPG^DDGFPG
S DDGFE=1
G SAVE^DDGFSV
;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
N DDGFS
I DDGFR D
. S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
. X IOXY W DDGFS_$J("",7-$L(DDGFS))
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
;
ERR(X) ;
D MSG^DDGF($C(7)_$P($T(@X),";;",2,999)) H 3
D MSG^DDGF()
Q
110 ;;There are no pages on this form. Use PF2-P to add a page.
120 ;;There are no blocks on this page. Use PF2-B to add a block.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGF1 3783 printed Sep 11, 2024@03:02:02 Page 2
DDGF1 ;SFISC/MKO-MAIN SCREEN ;02:46 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 DO RC($PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2))
+8 SET DDGFE=0
FOR
SET Y=$$READ
if $TEXT(@Y)=""
WRITE $CHAR(7)
if $DATA(DDGFMSG)
DO MSG^DDGF()
if $TEXT(@Y)]""
DO @Y
if DDGFE
QUIT
+9 QUIT
+10 ;
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
+2 ;
ELR NEW Y,X
+1 SET Y=DY
SET X=DX
+2 SET X=$ORDER(@DDGFREF@("RC",DDGFWID,Y,X))
+3 if X=""
Begin DoDot:1
+4 SET Y=$ORDER(@DDGFREF@("RC",DDGFWID,Y))
+5 if Y=""
SET Y=$ORDER(@DDGFREF@("RC",DDGFWID,""))
+6 if Y]""
SET X=$ORDER(@DDGFREF@("RC",DDGFWID,Y,""))
End DoDot:1
+7 if X]""
DO RC(Y,X)
+8 QUIT
ELL NEW Y,X
+1 SET Y=DY
SET X=DX
+2 SET X=$ORDER(@DDGFREF@("RC",DDGFWID,Y,X),-1)
+3 if X=""
Begin DoDot:1
+4 SET Y=$ORDER(@DDGFREF@("RC",DDGFWID,Y),-1)
+5 if Y=""
SET Y=$ORDER(@DDGFREF@("RC",DDGFWID,""),-1)
+6 if Y]""
SET X=$ORDER(@DDGFREF@("RC",DDGFWID,Y,""),-1)
End DoDot:1
+7 if X]""
DO RC(Y,X)
+8 QUIT
+9 ;
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
+2 ;
SAVE ;Save data from DDGFREF
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO SAVE^DDGFSV
+3 ;
SELECT ;Select an item
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO SELECT^DDGFEL
+3 ;
EDIT ;Edit a caption or data length
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO EDIT^DDGFEL
+3 ;
FLDADD ;Add a new field to the form
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO ADD^DDGFFLDA
+3 ;
VIEW ;Go to block viewer
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 IF $ORDER(@DDGFREF@("F",DDGFPG,""))=""
DO ERR(120)
QUIT
+3 GOTO ^DDGF3
+4 ;
BKADD ;Add a new block
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO ADD^DDGFBK
+3 ;
HBKADD ;Add a header block
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO ADD^DDGFHBK
+3 ;
NXTPG ;Go to next page
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 DO NXTPRV^DDGFPG(1)
QUIT
+3 ;
PRVPG ;Go to previous page
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 DO NXTPRV^DDGFPG(-1)
QUIT
+3 ;
CLSPG ;Close pop-up page
+1 GOTO CLSPG^DDGFPG
+2 ;
PGSEL ;Select a new page
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO PGSEL^DDGFPG
+3 ;
PGADD ;Add a new page to the form
+1 GOTO ADD^DDGFPG
+2 ;
PGEDIT ;Edit attributes of a page
+1 IF 'DDGFPG
DO ERR(110)
QUIT
+2 GOTO EDIT^DDGFPG
+3 ;
FMSEL ;Select another form
+1 GOTO SEL^DDGFFM
+2 ;
FMADD ;Add a new form
+1 GOTO ADD^DDGFFM
+2 ;
FMEDIT ;Edit the form
+1 GOTO EDIT^DDGFFM
+2 ;
HELP ;Invoke help screens
+1 GOTO HLP^DDGFH
+2 ;
TO ;Time-out
+1 WRITE $CHAR(7)
+2 GOTO QUIT
+3 ;
QUIT ;Exit from form designer
+1 IF DDGLSCR>1
GOTO CLSPG^DDGFPG
+2 SET DDGFE=1
+3 QUIT
EXIT ;Save and exit
+1 IF DDGLSCR>1
GOTO CLSPG^DDGFPG
+2 SET DDGFE=1
+3 GOTO SAVE^DDGFSV
+4 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
+1 NEW DDGFS
+2 IF DDGFR
Begin DoDot:1
+3 SET DY=IOSL-6
SET DX=IOM-9
SET DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
+4 XECUTE IOXY
WRITE DDGFS_$JUSTIFY("",7-$LENGTH(DDGFS))
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
+8 ;
ERR(X) ;
+1 DO MSG^DDGF($CHAR(7)_$PIECE($TEXT(@X),";;",2,999))
HANG 3
+2 DO MSG^DDGF()
+3 QUIT
110 ;;There are no pages on this form. Use PF2-P to add a page.
120 ;;There are no blocks on this page. Use PF2-B to add a block.
