DDGLIBW ;SFISC/MKO-WINDOW PRIMITIVES ;02:24 PM 13 Jul 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.
;
; Area is defined as $Y^$X^height^width
; DDGLREF(wid)=$Y^$X^height^width
; DDGLREF(wid,$Y+1,"TXT")=string
; DDGLREF(wid,$Y+1,"ATT")=attributes (bold,underline,reverse,graphic)
;
; DDGLSCR array - keeps track of what windows are on the screen and
; the order in which they overlap
; Form of DDGLSCR array:
; DDGLSCR = # of elements
; DDGLSCR(n) = wid
; DDGLSCR("B",wid,n)= ""
;
CREATE(I,A,B,N) ;
G CREATE1^DDGLIBW1
;
OPEN(I,N) ;
G OPEN1^DDGLIBW1
;
FOCUS(I,N) ;
G FOCUS1^DDGLIBW1
;
CLOSE(I,NC) ;
G CLOSE1^DDGLIBW1
;
CLEAR(I,A) ;
;Clear area A in window I
G CLEAR1^DDGLIBW1
;
EXIST(I) ;
;Does window I exist?
Q $D(@DDGLREF@(I))#2
;
CLOSEALL(N) ;
;Close all windows
W:'$G(N) $P(DDGLCLR,DDGLDEL,2)
K DDGLSCR
Q
;
DESTROY(I,NC) ;
;Destroy window I
D CLOSE(I,$G(NC))
K @DDGLREF@(I)
Q
;
DESTALL ;Destroy all windows
K @DDGLREF,DDGLSCR
Q
;
WRITE(I,S,Y,X,A,N) ;
;Write str S in window I at $Y=R, $X=C, attr A
; If N=1, update buffer, but don't write
N A1,A0,A9
Q:$G(S)=""
S:$G(I)="" I=-1
S A9=$$AREA(I)
Q:X'<$P(A9,U,4) Q:Y'<$P(A9,U,3)
S S=$E(S,1,$P(A9,U,4)-X)
;
S $E(@DDGLREF@(I,Y+1,"TXT"),X+1,X+$L(S))=S
I $G(A)="",$D(@DDGLREF@(I,Y+1,"ATT"))#2 S $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$J("",$L(S))
S:$G(A)]"" $E(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$L(S))=$TR($J("",$L(S))," ",$$CODE(A,.A1,.A0))
;
I '$G(N) D
. N DY,DX
. S DY=Y+$P(A9,U),DX=X+$P(A9,U,2) X IOXY W $G(A1)_S_$G(A0)
;
I $G(@DDGLREF@(I,Y+1,"TXT"))?." ",$G(@DDGLREF@(I,Y+1,"ATT"))?." " K @DDGLREF@(I,Y+1,"TXT"),@DDGLREF@(I,Y+1,"ATT")
Q
;
REPALL(A) ;
;Repaint absolute area A in all windows in DDGLSCR array
N J
I $G(A)="" D
. W $P(DDGLCLR,DDGLDEL,2)
. F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J))
E D
. D CLEAR(-1,A)
. F J=1:1:$G(DDGLSCR) D REPAINT(DDGLSCR(J),$$RELAREA(DDGLSCR(J),A))
Q
;
REPAINT(I,A) ;
;Repaint area A of window I
N X,Y,H,W,R,C,T,X1,X2,A2,A1,A0,S,DY,DX,P
I $D(A),A="" Q
S:$G(I)="" I=-1
S:'$D(A) A="0^0^"_IOSL_U_IOM
;
S A2=$$AREA(I)
S A=$P(A,U)+$P(A2,U)_U_($P(A,U,2)+$P(A2,U,2))_U_$P(A,U,3,4)
S A=$$INTSECT^DDGLIBW1(A,A2)
S Y=$P(A,U)-$P(A2,U),X=$P(A,U,2)-$P(A2,U,2),H=$P(A,U,3),W=$P(A,U,4)
;
I $D(@DDGLREF@(I))<9,Y+$P(A2,U)=0,X+$P(A2,U,2)=0,H=IOSL,W=IOM W $P(DDGLCLR,DDGLDEL,2) Q
S P=IOM-X-$P(A2,U,2)-1_""" """
F R=Y+1:1:Y+H D
. S S=""
. S T=$E($G(@DDGLREF@(I,R,"TXT"))_$J("",X+W-$L($G(@DDGLREF@(I,R,"TXT")))),1,X+W)
. S A=$E($G(@DDGLREF@(I,R,"ATT")),1,X+W)
. S (X1,X2)=X+1 F D Q:$E(T,X2)=""
.. S X1=X2,C=$E(A,X1)
.. I C="" S X2=999 S S=S_$E(T,X1,X2) Q
.. F X2=X1:1:$L(A)+1 Q:C'=$E(A,X2)
.. D DECODE(C,.A1,.A0)
.. S S=S_A1_$E(T,X1,X2-1)_A0
. S DY=R-1+$P(A2,U),DX=X+$P(A2,U,2) X IOXY
. W $S(S?@P:$P(DDGLCLR,DDGLDEL),1:S)
Q
;
BOX(I,A,C,N) ;
;Draw a box in window I representing area A
;If C=1 writes spaces within the box
;If N=1 write to buffer but not screen
N Y,X,H,W,L,R,S,A1
S:$G(I)="" I=-1
S:$G(A)="" A=$$AREA(I)
S:$G(N)="" N=0
S A1=$$ABSAREA(I,A)
S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
Q:'H!'W
S S=$J("",W-2),L=$TR(S," ",$P(DDGLGRA,DDGLDEL,3))
D WRITE(I,$P(DDGLGRA,DDGLDEL,5)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,6),1:""),Y,X,"G",N)
F R=Y+1:1:Y+H-2 D
. D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X,"G",N)
. I W>1 D
.. I $G(C) D WRITE(I,S,R,X+1,"",N)
.. D WRITE(I,$P(DDGLGRA,DDGLDEL,4),R,X+W-1,"G",N)
D:H>1 WRITE(I,$P(DDGLGRA,DDGLDEL,7)_$S(W>1:L_$P(DDGLGRA,DDGLDEL,8),1:""),Y+H-1,X,"G",N)
Q
;
ABSAREA(I,A) ;
;Given relative area A in window I, return absolute area
N X,Y,H,W,X1,Y1
S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
S A=$$AREA(I)
S Y1=Y+$P(A,U),X1=X+$P(A,U,2)
S:Y1+H>IOSL H=IOSL-Y1 S:X1+W>IOM W=IOM-X1
Q Y1_U_X1_U_H_U_W
;
RELAREA(I,A) ;
;Given absolute area A in window I, return relative area
N X,Y,H,W,X1,Y1
S Y=$P(A,U),X=$P(A,U,2),H=$P(A,U,3),W=$P(A,U,4)
S A=$$AREA(I)
S Y1=Y-$P(A,U),X1=X-$P(A,U,2)
Q Y1_U_X1_U_H_U_W
;
AREA(I) ;Return the coord and area of window I
Q $S($D(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM)
;
CODE(A,A1,A0) ;
;Return code char for selected attr
N I,C,T
S C=0,(A1,A0)=""
S T=$TR(A,"burg","BURG")
F I=1:1:$L(A) D
. S T=$T(@$E(A,I))
. I T]"" D
.. S C=C+$P(T,";",3)
.. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5))
.. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6))
Q $C(C+32)
;
DECODE(C,A1,A0) ;
;Given code char C, return codes to turn on/off attr
N B,T
S (A1,A0)="" Q:" "[$G(C)
S C=$A(C)-32
S B=1 F D Q:B>8
. I C\B#2,$T(@B)]"" D
.. S T=$T(@B+1)
.. S A1=A1_$P(@$P(T,";",4),DDGLDEL,$P(T,";",5))
.. S A0=A0_$P(@$P(T,";",4),DDGLDEL,$P(T,";",6))
. S B=B*2
Q
;
1 ;;
B ;;1;DDGLVID;1;2
2 ;;
U ;;2;DDGLVID;4;5
4 ;;
R ;;4;DDGLVID;6;7
8 ;;
G ;;8;DDGLGRA;1;2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGLIBW 5198 printed Sep 23, 2025@20:18:43 Page 2
DDGLIBW ;SFISC/MKO-WINDOW PRIMITIVES ;02:24 PM 13 Jul 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 ; Area is defined as $Y^$X^height^width
+8 ; DDGLREF(wid)=$Y^$X^height^width
+9 ; DDGLREF(wid,$Y+1,"TXT")=string
+10 ; DDGLREF(wid,$Y+1,"ATT")=attributes (bold,underline,reverse,graphic)
+11 ;
+12 ; DDGLSCR array - keeps track of what windows are on the screen and
+13 ; the order in which they overlap
+14 ; Form of DDGLSCR array:
+15 ; DDGLSCR = # of elements
+16 ; DDGLSCR(n) = wid
+17 ; DDGLSCR("B",wid,n)= ""
+18 ;
CREATE(I,A,B,N) ;
+1 GOTO CREATE1^DDGLIBW1
+2 ;
OPEN(I,N) ;
+1 GOTO OPEN1^DDGLIBW1
+2 ;
FOCUS(I,N) ;
+1 GOTO FOCUS1^DDGLIBW1
+2 ;
CLOSE(I,NC) ;
+1 GOTO CLOSE1^DDGLIBW1
+2 ;
CLEAR(I,A) ;
+1 ;Clear area A in window I
+2 GOTO CLEAR1^DDGLIBW1
+3 ;
EXIST(I) ;
+1 ;Does window I exist?
+2 QUIT $DATA(@DDGLREF@(I))#2
+3 ;
CLOSEALL(N) ;
+1 ;Close all windows
+2 if '$GET(N)
WRITE $PIECE(DDGLCLR,DDGLDEL,2)
+3 KILL DDGLSCR
+4 QUIT
+5 ;
DESTROY(I,NC) ;
+1 ;Destroy window I
+2 DO CLOSE(I,$GET(NC))
+3 KILL @DDGLREF@(I)
+4 QUIT
+5 ;
DESTALL ;Destroy all windows
+1 KILL @DDGLREF,DDGLSCR
+2 QUIT
+3 ;
WRITE(I,S,Y,X,A,N) ;
+1 ;Write str S in window I at $Y=R, $X=C, attr A
+2 ; If N=1, update buffer, but don't write
+3 NEW A1,A0,A9
+4 if $GET(S)=""
QUIT
+5 if $GET(I)=""
SET I=-1
+6 SET A9=$$AREA(I)
+7 if X'<$PIECE(A9,U,4)
QUIT
if Y'<$PIECE(A9,U,3)
QUIT
+8 SET S=$EXTRACT(S,1,$PIECE(A9,U,4)-X)
+9 ;
+10 SET $EXTRACT(@DDGLREF@(I,Y+1,"TXT"),X+1,X+$LENGTH(S))=S
+11 IF $GET(A)=""
IF $DATA(@DDGLREF@(I,Y+1,"ATT"))#2
SET $EXTRACT(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$LENGTH(S))=$JUSTIFY("",$LENGTH(S))
+12 if $GET(A)]""
SET $EXTRACT(@DDGLREF@(I,Y+1,"ATT"),X+1,X+$LENGTH(S))=$TRANSLATE($JUSTIFY("",$LENGTH(S))," ",$$CODE(A,.A1,.A0))
+13 ;
+14 IF '$GET(N)
Begin DoDot:1
+15 NEW DY,DX
+16 SET DY=Y+$PIECE(A9,U)
SET DX=X+$PIECE(A9,U,2)
XECUTE IOXY
WRITE $GET(A1)_S_$GET(A0)
End DoDot:1
+17 ;
+18 IF $GET(@DDGLREF@(I,Y+1,"TXT"))?." "
IF $GET(@DDGLREF@(I,Y+1,"ATT"))?." "
KILL @DDGLREF@(I,Y+1,"TXT"),@DDGLREF@(I,Y+1,"ATT")
+19 QUIT
+20 ;
REPALL(A) ;
+1 ;Repaint absolute area A in all windows in DDGLSCR array
+2 NEW J
+3 IF $GET(A)=""
Begin DoDot:1
+4 WRITE $PIECE(DDGLCLR,DDGLDEL,2)
+5 FOR J=1:1:$GET(DDGLSCR)
DO REPAINT(DDGLSCR(J))
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 DO CLEAR(-1,A)
+8 FOR J=1:1:$GET(DDGLSCR)
DO REPAINT(DDGLSCR(J),$$RELAREA(DDGLSCR(J),A))
End DoDot:1
+9 QUIT
+10 ;
REPAINT(I,A) ;
+1 ;Repaint area A of window I
+2 NEW X,Y,H,W,R,C,T,X1,X2,A2,A1,A0,S,DY,DX,P
+3 IF $DATA(A)
IF A=""
QUIT
+4 if $GET(I)=""
SET I=-1
+5 if '$DATA(A)
SET A="0^0^"_IOSL_U_IOM
+6 ;
+7 SET A2=$$AREA(I)
+8 SET A=$PIECE(A,U)+$PIECE(A2,U)_U_($PIECE(A,U,2)+$PIECE(A2,U,2))_U_$PIECE(A,U,3,4)
+9 SET A=$$INTSECT^DDGLIBW1(A,A2)
+10 SET Y=$PIECE(A,U)-$PIECE(A2,U)
SET X=$PIECE(A,U,2)-$PIECE(A2,U,2)
SET H=$PIECE(A,U,3)
SET W=$PIECE(A,U,4)
+11 ;
+12 IF $DATA(@DDGLREF@(I))<9
IF Y+$PIECE(A2,U)=0
IF X+$PIECE(A2,U,2)=0
IF H=IOSL
IF W=IOM
WRITE $PIECE(DDGLCLR,DDGLDEL,2)
QUIT
+13 SET P=IOM-X-$PIECE(A2,U,2)-1_""" """
+14 FOR R=Y+1:1:Y+H
Begin DoDot:1
+15 SET S=""
+16 SET T=$EXTRACT($GET(@DDGLREF@(I,R,"TXT"))_$JUSTIFY("",X+W-$LENGTH($GET(@DDGLREF@(I,R,"TXT")))),1,X+W)
+17 SET A=$EXTRACT($GET(@DDGLREF@(I,R,"ATT")),1,X+W)
+18 SET (X1,X2)=X+1
FOR
Begin DoDot:2
+19 SET X1=X2
SET C=$EXTRACT(A,X1)
+20 IF C=""
SET X2=999
SET S=S_$EXTRACT(T,X1,X2)
QUIT
+21 FOR X2=X1:1:$LENGTH(A)+1
if C'=$EXTRACT(A,X2)
QUIT
+22 DO DECODE(C,.A1,.A0)
+23 SET S=S_A1_$EXTRACT(T,X1,X2-1)_A0
End DoDot:2
if $EXTRACT(T,X2)=""
QUIT
+24 SET DY=R-1+$PIECE(A2,U)
SET DX=X+$PIECE(A2,U,2)
XECUTE IOXY
+25 WRITE $SELECT(S?@P:$PIECE(DDGLCLR,DDGLDEL),1:S)
End DoDot:1
+26 QUIT
+27 ;
BOX(I,A,C,N) ;
+1 ;Draw a box in window I representing area A
+2 ;If C=1 writes spaces within the box
+3 ;If N=1 write to buffer but not screen
+4 NEW Y,X,H,W,L,R,S,A1
+5 if $GET(I)=""
SET I=-1
+6 if $GET(A)=""
SET A=$$AREA(I)
+7 if $GET(N)=""
SET N=0
+8 SET A1=$$ABSAREA(I,A)
+9 SET Y=$PIECE(A,U)
SET X=$PIECE(A,U,2)
SET H=$PIECE(A,U,3)
SET W=$PIECE(A,U,4)
+10 if 'H!'W
QUIT
+11 SET S=$JUSTIFY("",W-2)
SET L=$TRANSLATE(S," ",$PIECE(DDGLGRA,DDGLDEL,3))
+12 DO WRITE(I,$PIECE(DDGLGRA,DDGLDEL,5)_$SELECT(W>1:L_$PIECE(DDGLGRA,DDGLDEL,6),1:""),Y,X,"G",N)
+13 FOR R=Y+1:1:Y+H-2
Begin DoDot:1
+14 DO WRITE(I,$PIECE(DDGLGRA,DDGLDEL,4),R,X,"G",N)
+15 IF W>1
Begin DoDot:2
+16 IF $GET(C)
DO WRITE(I,S,R,X+1,"",N)
+17 DO WRITE(I,$PIECE(DDGLGRA,DDGLDEL,4),R,X+W-1,"G",N)
End DoDot:2
End DoDot:1
+18 if H>1
DO WRITE(I,$PIECE(DDGLGRA,DDGLDEL,7)_$SELECT(W>1:L_$PIECE(DDGLGRA,DDGLDEL,8),1:""),Y+H-1,X,"G",N)
+19 QUIT
+20 ;
ABSAREA(I,A) ;
+1 ;Given relative area A in window I, return absolute area
+2 NEW X,Y,H,W,X1,Y1
+3 SET Y=$PIECE(A,U)
SET X=$PIECE(A,U,2)
SET H=$PIECE(A,U,3)
SET W=$PIECE(A,U,4)
+4 SET A=$$AREA(I)
+5 SET Y1=Y+$PIECE(A,U)
SET X1=X+$PIECE(A,U,2)
+6 if Y1+H>IOSL
SET H=IOSL-Y1
if X1+W>IOM
SET W=IOM-X1
+7 QUIT Y1_U_X1_U_H_U_W
+8 ;
RELAREA(I,A) ;
+1 ;Given absolute area A in window I, return relative area
+2 NEW X,Y,H,W,X1,Y1
+3 SET Y=$PIECE(A,U)
SET X=$PIECE(A,U,2)
SET H=$PIECE(A,U,3)
SET W=$PIECE(A,U,4)
+4 SET A=$$AREA(I)
+5 SET Y1=Y-$PIECE(A,U)
SET X1=X-$PIECE(A,U,2)
+6 QUIT Y1_U_X1_U_H_U_W
+7 ;
AREA(I) ;Return the coord and area of window I
+1 QUIT $SELECT($DATA(@DDGLREF@(I))#2:@DDGLREF@(I),1:"0^0^"_IOSL_U_IOM)
+2 ;
CODE(A,A1,A0) ;
+1 ;Return code char for selected attr
+2 NEW I,C,T
+3 SET C=0
SET (A1,A0)=""
+4 SET T=$TRANSLATE(A,"burg","BURG")
+5 FOR I=1:1:$LENGTH(A)
Begin DoDot:1
+6 SET T=$TEXT(@$EXTRACT(A,I))
+7 IF T]""
Begin DoDot:2
+8 SET C=C+$PIECE(T,";",3)
+9 SET A1=A1_$PIECE(@$PIECE(T,";",4),DDGLDEL,$PIECE(T,";",5))
+10 SET A0=A0_$PIECE(@$PIECE(T,";",4),DDGLDEL,$PIECE(T,";",6))
End DoDot:2
End DoDot:1
+11 QUIT $CHAR(C+32)
+12 ;
DECODE(C,A1,A0) ;
+1 ;Given code char C, return codes to turn on/off attr
+2 NEW B,T
+3 SET (A1,A0)=""
if " "[$GET(C)
QUIT
+4 SET C=$ASCII(C)-32
+5 SET B=1
FOR
Begin DoDot:1
+6 IF C\B#2
IF $TEXT(@B)]""
Begin DoDot:2
+7 SET T=$TEXT(@B+1)
+8 SET A1=A1_$PIECE(@$PIECE(T,";",4),DDGLDEL,$PIECE(T,";",5))
+9 SET A0=A0_$PIECE(@$PIECE(T,";",4),DDGLDEL,$PIECE(T,";",6))
End DoDot:2
+10 SET B=B*2
End DoDot:1
if B>8
QUIT
+11 QUIT
+12 ;
1 ;;
B ;;1;DDGLVID;1;2
2 ;;
U ;;2;DDGLVID;4;5
4 ;;
R ;;4;DDGLVID;6;7
8 ;;
G ;;8;DDGLGRA;1;2
