DDGLIBH ;SFISC/MKO-SCREEN EDITOR HELP ;15NOV2012
;;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.
;
HLP(DDGLHN1,DDGLHN2,DDGLSUB,DDGLPLN) ;
;DDGLHN1 = Entry number in Dialog file of first help screen
;DDGLHN2 = Entry number of last help screen
;DDGLSUB = Subscript in ^TMP to copy help to
;DDGLPLN = $Y to print prompt
;
N DX,DY,DDGLI,DDGLJ,DDGLSC,DDGLTX,DDGLX,DIHELP,DDGL0
S DDGL0=$C(31)
D:'$D(DDGLH) GETKEY
I $D(IOTM)[0 N IOTM S IOTM=1
I $D(IOBM)[0 N IOBM S IOBM=IOSL
I '$G(DDGLPLN) S DDGLPLN=IOBM-1
S DDGLSC=DDGLHN1
;
D DISP(DDGLHN1)
;
F S DDGLX=$$READ D @DDGLX Q:DDGLX=U
Q
;
UP I DDGLSC>DDGLHN1 S DDGLSC=DDGLSC-1 D DISP(DDGLSC)
Q
;
DN I DDGLSC<DDGLHN2 S DDGLSC=DDGLSC+1 D DISP(DDGLSC)
Q
;
TO W $C(7)
QT S DDGLX=U
Q
;
PT ;Prompt for device and print
;Clear screen
N POP
N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N
N %P,%S,%T,%W,%X,%Y
N %A0,%D1,%D2,%DT,%J1,%W0
;
S DY=IOTM-1,DX=0 X IOXY
W $P(DDGLVID,DDGLDEL)_"PRINT THE HELP SCREENS"_$P(DDGLVID,DDGLDEL,10)_$P(DDGLCLR,DDGLDEL)
F DDGLI=1:1:IOBM-IOTM W $C(13,10)_$P(DDGLCLR,DDGLDEL)
S DY=IOTM+1,DX=0 X IOXY
;
X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
S X=$G(IOM,80) X DDGLZOSF("RM") ; VEN/SMH changed.
W $P(DDGLVID,DDGLDEL,9)
;
DEVICE ;Device prompt
N IOF,IOSL
S IOF="#",IOSL=IOBM-IOTM+1 ;In case help frames are invoked
S %ZIS=$S($D(^%ZTSK):"Q",1:""),%ZIS("B")=""
D ^%ZIS K %ZIS
;
I POP D
. W !!,"Report canceled!"
. H 2
;
;Queue report
E I $D(IO("Q")),$D(^%ZTSK) D
. S ZTRTN="PRINT^DDGLIBH"
. S ZTDESC="Help screen printout."
. N I F I="DDGLHN1","DDGLHN2" S ZTSAVE(I)=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_ZTSK,!
. E W !,"Report canceled!",!
. K ZTSK
. S IOP="HOME" D ^%ZIS
;
E I $E(IOST,1,2)="C-" D
. W !,$C(7)_"You cannot print the help screens on a CRT.",!
. H 2
;
;Non-queued report
E D
. W !,"Printing ..."
. U IO
. D PRINT
. X $G(^%ZIS("C"))
;
;Repaint help screen
X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
S X=0 X DDGLZOSF("RM") ; VEN/SMH changed.
W $P(DDGLVID,DDGLDEL,8)
D DISP(DDGLSC)
Q
;
PRINT ;
N DDGLJ,DDGLL,DDGLP
F DDGLI=DDGLHN1:1:DDGLHN2 D
. I DDGLI'=DDGLHN1 D
.. I $Y+$O(^DI(.84,DDGLI,2," "),-1)+2'<IOSL W @IOF
.. E W !!
. S DDGLJ=0
. F S DDGLJ=$O(^DI(.84,DDGLI,2,DDGLJ)) Q:'DDGLJ D
.. S DDGLL=$G(^DI(.84,DDGLI,2,DDGLJ,0))
.. F Q:DDGLL'["\" D
... S DDGLP=$F(DDGLL,"\") Q:$E(DDGLL,DDGLP)="\"
... S $E(DDGLL,DDGLP-1,DDGLP)=""
.. W !,DDGLL
;
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
DISP(DDGLHN) ;Print help screen DDGLHN
N DDGLHARR
S DDGLHARR=$NA(^TMP(DDGLSUB,$J,DDGLHN))
D:'$D(@DDGLHARR) BLD^DIALOG(DDGLHN,"","",DDGLHARR)
;
S DY=IOTM-1,DX=0 X IOXY
F DDGLI=1:1 Q:'$D(@DDGLHARR@(DDGLI)) S DDGLTX=^(DDGLI) D
. I DDGLTX["\B" F S DDGLJ=$F(DDGLTX,"\B") Q:'DDGLJ D
.. S $E(DDGLTX,DDGLJ-2,DDGLJ-1)=$P(DDGLVID,DDGLDEL)
. I DDGLTX["\n" F S DDGLJ=$F(DDGLTX,"\n") Q:'DDGLJ D
.. S $E(DDGLTX,DDGLJ-2,DDGLJ-1)=$P(DDGLVID,DDGLDEL,10)
. W $S(DDGLI>1:$C(13,10),1:"")_DDGLTX_$P(DDGLCLR,DDGLDEL)
;
F DDGLI=DDGLI:1:IOBM-IOTM+1 W $C(13,10)_$P(DDGLCLR,DDGLDEL)
Q
;
READ() ;
S DY=DDGLPLN,DX=0 X IOXY
W $P(DDGLCLR,DDGLDEL)_"Press "
W:DDGLSC>DDGLHN1 $P(DDGLVID,DDGLDEL)_"<Up>"_$P(DDGLVID,DDGLDEL,10)_" for previous page, "
W:DDGLSC<DDGLHN2 $P(DDGLVID,DDGLDEL)_"<Down>"_$P(DDGLVID,DDGLDEL,10)_" for next page, "
W $P(DDGLVID,DDGLDEL)_"P"_$P(DDGLVID,DDGLDEL,10)_" to print, "
W $P(DDGLVID,DDGLDEL)_"^"_$P(DDGLVID,DDGLDEL,10)_" to exit: "
D GETCH(DTIME,.DDGLX)
S DY=DDGLPLN,DX=0 X IOXY W $P(DDGLCLR,DDGLDEL)
Q DDGLX
;
GETCH(DTIME,Y) ;Out: Y = Mnemonic
F D Q:Y'=-1
. R *Y:DTIME
. I Y<0 S Y="TO" Q
. D MNE(.Y)
Q
;
MNE(Y) ;Out: Y = Mnemonic, or -1 if invalid
N S,F
S S="",F=0
F D MNELOOP Q:F
Q
;
MNELOOP ;Read more
S S=S_$C(Y)
I DDGLH("IN")'[(DDGL0_S) D I Y=-1 D FLUSH Q
. I $C(Y)'?1L S Y=-1 Q
. S S=$E(S,1,$L(S)-1)_$C(Y-32)
. S:DDGLH("IN")'[(DDGL0_S_DDGL0) Y=-1
;
I DDGLH("IN")[(DDGL0_S_DDGL0),S'=$C(27) D Q
. S Y=$P(DDGLH("OUT"),DDGL0,$L($P(DDGLH("IN"),DDGL0_S_DDGL0),DDGL0)),F=1
;
R *Y:5 D:Y=-1 FLUSH
Q
;
FLUSH ;
N DDGLZ
S F=1 W $C(7) F R *DDGLZ:0 E Q
Q
;
GETKEY ;Get key sequences and defaults
N AU,AD,F1,PREVSC,NEXTSC
N I,K,N,T
S AU=$P(DDGLKEY,U,2)
S AD=$P(DDGLKEY,U,3)
S F1=$P(DDGLKEY,U,6)
S PREVSC=$P(DDGLKEY,U,14)
S NEXTSC=$P(DDGLKEY,U,15)
;
K DDGLH
S DDGLH("IN")="",DDGLH("OUT")=""
F I=1:1 S T=$P($T(MAP+I),";;",2,999) Q:T="" D
. S @("K="_$P(T,";",2))
. I DDGLH("IN")'[(DDGL0_K),K]"" D
.. S DDGLH("IN")=DDGLH("IN")_DDGL0_K
.. S DDGLH("OUT")=DDGLH("OUT")_$P(T,";")_DDGL0
S DDGLH("IN")=DDGLH("IN")_DDGL0
S DDGLH("OUT")=$E(DDGLH("OUT"),1,$L(DDGLH("OUT"))-1)
Q
;
MAP ;Keys
;;DN;$C(13)
;;DN;AD
;;DN;F1_AD
;;DN;NEXTSC
;;UP;AU
;;UP;F1_AU
;;UP;PREVSC
;;QT;F1_"E"
;;QT;F1_"Q"
;;QT;"^"
;;PT;"P"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGLIBH 5199 printed Sep 23, 2025@20:18:41 Page 2
DDGLIBH ;SFISC/MKO-SCREEN EDITOR HELP ;15NOV2012
+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 ;
HLP(DDGLHN1,DDGLHN2,DDGLSUB,DDGLPLN) ;
+1 ;DDGLHN1 = Entry number in Dialog file of first help screen
+2 ;DDGLHN2 = Entry number of last help screen
+3 ;DDGLSUB = Subscript in ^TMP to copy help to
+4 ;DDGLPLN = $Y to print prompt
+5 ;
+6 NEW DX,DY,DDGLI,DDGLJ,DDGLSC,DDGLTX,DDGLX,DIHELP,DDGL0
+7 SET DDGL0=$CHAR(31)
+8 if '$DATA(DDGLH)
DO GETKEY
+9 IF $DATA(IOTM)[0
NEW IOTM
SET IOTM=1
+10 IF $DATA(IOBM)[0
NEW IOBM
SET IOBM=IOSL
+11 IF '$GET(DDGLPLN)
SET DDGLPLN=IOBM-1
+12 SET DDGLSC=DDGLHN1
+13 ;
+14 DO DISP(DDGLHN1)
+15 ;
+16 FOR
SET DDGLX=$$READ
DO @DDGLX
if DDGLX=U
QUIT
+17 QUIT
+18 ;
UP IF DDGLSC>DDGLHN1
SET DDGLSC=DDGLSC-1
DO DISP(DDGLSC)
+1 QUIT
+2 ;
DN IF DDGLSC<DDGLHN2
SET DDGLSC=DDGLSC+1
DO DISP(DDGLSC)
+1 QUIT
+2 ;
TO WRITE $CHAR(7)
QT SET DDGLX=U
+1 QUIT
+2 ;
PT ;Prompt for device and print
+1 ;Clear screen
+2 NEW POP
+3 NEW %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%K,%M,%N
+4 NEW %P,%S,%T,%W,%X,%Y
+5 NEW %A0,%D1,%D2,%DT,%J1,%W0
+6 ;
+7 SET DY=IOTM-1
SET DX=0
XECUTE IOXY
+8 WRITE $PIECE(DDGLVID,DDGLDEL)_"PRINT THE HELP SCREENS"_$PIECE(DDGLVID,DDGLDEL,10)_$PIECE(DDGLCLR,DDGLDEL)
+9 FOR DDGLI=1:1:IOBM-IOTM
WRITE $CHAR(13,10)_$PIECE(DDGLCLR,DDGLDEL)
+10 SET DY=IOTM+1
SET DX=0
XECUTE IOXY
+11 ;
+12 XECUTE DDGLZOSF("EON")
XECUTE DDGLZOSF("TRMOFF")
+13 ; VEN/SMH changed.
SET X=$GET(IOM,80)
XECUTE DDGLZOSF("RM")
+14 WRITE $PIECE(DDGLVID,DDGLDEL,9)
+15 ;
DEVICE ;Device prompt
+1 NEW IOF,IOSL
+2 ;In case help frames are invoked
SET IOF="#"
SET IOSL=IOBM-IOTM+1
+3 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
SET %ZIS("B")=""
+4 DO ^%ZIS
KILL %ZIS
+5 ;
+6 IF POP
Begin DoDot:1
+7 WRITE !!,"Report canceled!"
+8 HANG 2
End DoDot:1
+9 ;
+10 ;Queue report
+11 IF '$TEST
IF $DATA(IO("Q"))
IF $DATA(^%ZTSK)
Begin DoDot:1
+12 SET ZTRTN="PRINT^DDGLIBH"
+13 SET ZTDESC="Help screen printout."
+14 NEW I
FOR I="DDGLHN1","DDGLHN2"
SET ZTSAVE(I)=""
+15 DO ^%ZTLOAD
+16 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_ZTSK,!
+17 IF '$TEST
WRITE !,"Report canceled!",!
+18 KILL ZTSK
+19 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
+20 ;
+21 IF '$TEST
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+22 WRITE !,$CHAR(7)_"You cannot print the help screens on a CRT.",!
+23 HANG 2
End DoDot:1
+24 ;
+25 ;Non-queued report
+26 IF '$TEST
Begin DoDot:1
+27 WRITE !,"Printing ..."
+28 USE IO
+29 DO PRINT
+30 XECUTE $GET(^%ZIS("C"))
End DoDot:1
+31 ;
+32 ;Repaint help screen
+33 XECUTE DDGLZOSF("EOFF")
XECUTE DDGLZOSF("TRMON")
+34 ; VEN/SMH changed.
SET X=0
XECUTE DDGLZOSF("RM")
+35 WRITE $PIECE(DDGLVID,DDGLDEL,8)
+36 DO DISP(DDGLSC)
+37 QUIT
+38 ;
PRINT ;
+1 NEW DDGLJ,DDGLL,DDGLP
+2 FOR DDGLI=DDGLHN1:1:DDGLHN2
Begin DoDot:1
+3 IF DDGLI'=DDGLHN1
Begin DoDot:2
+4 IF $Y+$ORDER(^DI(.84,DDGLI,2," "),-1)+2'<IOSL
WRITE @IOF
+5 IF '$TEST
WRITE !!
End DoDot:2
+6 SET DDGLJ=0
+7 FOR
SET DDGLJ=$ORDER(^DI(.84,DDGLI,2,DDGLJ))
if 'DDGLJ
QUIT
Begin DoDot:2
+8 SET DDGLL=$GET(^DI(.84,DDGLI,2,DDGLJ,0))
+9 FOR
if DDGLL'["\"
QUIT
Begin DoDot:3
+10 SET DDGLP=$FIND(DDGLL,"\")
if $EXTRACT(DDGLL,DDGLP)="\"
QUIT
+11 SET $EXTRACT(DDGLL,DDGLP-1,DDGLP)=""
End DoDot:3
+12 WRITE !,DDGLL
End DoDot:2
End DoDot:1
+13 ;
+14 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+15 QUIT
+16 ;
DISP(DDGLHN) ;Print help screen DDGLHN
+1 NEW DDGLHARR
+2 SET DDGLHARR=$NAME(^TMP(DDGLSUB,$JOB,DDGLHN))
+3 if '$DATA(@DDGLHARR)
DO BLD^DIALOG(DDGLHN,"","",DDGLHARR)
+4 ;
+5 SET DY=IOTM-1
SET DX=0
XECUTE IOXY
+6 FOR DDGLI=1:1
if '$DATA(@DDGLHARR@(DDGLI))
QUIT
SET DDGLTX=^(DDGLI)
Begin DoDot:1
+7 IF DDGLTX["\B"
FOR
SET DDGLJ=$FIND(DDGLTX,"\B")
if 'DDGLJ
QUIT
Begin DoDot:2
+8 SET $EXTRACT(DDGLTX,DDGLJ-2,DDGLJ-1)=$PIECE(DDGLVID,DDGLDEL)
End DoDot:2
+9 IF DDGLTX["\n"
FOR
SET DDGLJ=$FIND(DDGLTX,"\n")
if 'DDGLJ
QUIT
Begin DoDot:2
+10 SET $EXTRACT(DDGLTX,DDGLJ-2,DDGLJ-1)=$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:2
+11 WRITE $SELECT(DDGLI>1:$CHAR(13,10),1:"")_DDGLTX_$PIECE(DDGLCLR,DDGLDEL)
End DoDot:1
+12 ;
+13 FOR DDGLI=DDGLI:1:IOBM-IOTM+1
WRITE $CHAR(13,10)_$PIECE(DDGLCLR,DDGLDEL)
+14 QUIT
+15 ;
READ() ;
+1 SET DY=DDGLPLN
SET DX=0
XECUTE IOXY
+2 WRITE $PIECE(DDGLCLR,DDGLDEL)_"Press "
+3 if DDGLSC>DDGLHN1
WRITE $PIECE(DDGLVID,DDGLDEL)_"<Up>"_$PIECE(DDGLVID,DDGLDEL,10)_" for previous page, "
+4 if DDGLSC<DDGLHN2
WRITE $PIECE(DDGLVID,DDGLDEL)_"<Down>"_$PIECE(DDGLVID,DDGLDEL,10)_" for next page, "
+5 WRITE $PIECE(DDGLVID,DDGLDEL)_"P"_$PIECE(DDGLVID,DDGLDEL,10)_" to print, "
+6 WRITE $PIECE(DDGLVID,DDGLDEL)_"^"_$PIECE(DDGLVID,DDGLDEL,10)_" to exit: "
+7 DO GETCH(DTIME,.DDGLX)
+8 SET DY=DDGLPLN
SET DX=0
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+9 QUIT DDGLX
+10 ;
GETCH(DTIME,Y) ;Out: Y = Mnemonic
+1 FOR
Begin DoDot:1
+2 READ *Y:DTIME
+3 IF Y<0
SET Y="TO"
QUIT
+4 DO MNE(.Y)
End DoDot:1
if Y'=-1
QUIT
+5 QUIT
+6 ;
MNE(Y) ;Out: Y = Mnemonic, or -1 if invalid
+1 NEW S,F
+2 SET S=""
SET F=0
+3 FOR
DO MNELOOP
if F
QUIT
+4 QUIT
+5 ;
MNELOOP ;Read more
+1 SET S=S_$CHAR(Y)
+2 IF DDGLH("IN")'[(DDGL0_S)
Begin DoDot:1
+3 IF $CHAR(Y)'?1L
SET Y=-1
QUIT
+4 SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)
+5 if DDGLH("IN")'[(DDGL0_S_DDGL0)
SET Y=-1
End DoDot:1
IF Y=-1
DO FLUSH
QUIT
+6 ;
+7 IF DDGLH("IN")[(DDGL0_S_DDGL0)
IF S'=$CHAR(27)
Begin DoDot:1
+8 SET Y=$PIECE(DDGLH("OUT"),DDGL0,$LENGTH($PIECE(DDGLH("IN"),DDGL0_S_DDGL0),DDGL0))
SET F=1
End DoDot:1
QUIT
+9 ;
+10 READ *Y:5
if Y=-1
DO FLUSH
+11 QUIT
+12 ;
FLUSH ;
+1 NEW DDGLZ
+2 SET F=1
WRITE $CHAR(7)
FOR
READ *DDGLZ:0
IF '$TEST
QUIT
+3 QUIT
+4 ;
GETKEY ;Get key sequences and defaults
+1 NEW AU,AD,F1,PREVSC,NEXTSC
+2 NEW I,K,N,T
+3 SET AU=$PIECE(DDGLKEY,U,2)
+4 SET AD=$PIECE(DDGLKEY,U,3)
+5 SET F1=$PIECE(DDGLKEY,U,6)
+6 SET PREVSC=$PIECE(DDGLKEY,U,14)
+7 SET NEXTSC=$PIECE(DDGLKEY,U,15)
+8 ;
+9 KILL DDGLH
+10 SET DDGLH("IN")=""
SET DDGLH("OUT")=""
+11 FOR I=1:1
SET T=$PIECE($TEXT(MAP+I),";;",2,999)
if T=""
QUIT
Begin DoDot:1
+12 SET @("K="_$PIECE(T,";",2))
+13 IF DDGLH("IN")'[(DDGL0_K)
IF K]""
Begin DoDot:2
+14 SET DDGLH("IN")=DDGLH("IN")_DDGL0_K
+15 SET DDGLH("OUT")=DDGLH("OUT")_$PIECE(T,";")_DDGL0
End DoDot:2
End DoDot:1
+16 SET DDGLH("IN")=DDGLH("IN")_DDGL0
+17 SET DDGLH("OUT")=$EXTRACT(DDGLH("OUT"),1,$LENGTH(DDGLH("OUT"))-1)
+18 QUIT
+19 ;
MAP ;Keys
+1 ;;DN;$C(13)
+2 ;;DN;AD
+3 ;;DN;F1_AD
+4 ;;DN;NEXTSC
+5 ;;UP;AU
+6 ;;UP;F1_AU
+7 ;;UP;PREVSC
+8 ;;QT;F1_"E"
+9 ;;QT;F1_"Q"
+10 ;;QT;"^"
+11 ;;PT;"P"
