DDBR4 ;SFISC/DCL-LOAD CURRENT LIST ;NOV 04, 1996@13:49
;;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.
;
LOADCL(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,DDBLST) ;
;DDBSA=source array by value
;DDGFLG=no flags currently available
;DDBPMSG=text to be displayed (centered) on top line
;DDBL=display line default 1st screen/line (22 in most cases)
;DDBC=location of column tab array used with right/left arrow keys
;DDBLST=location of current list (BROWSER expects ^TMP("DDBLST",$J))
I $G(DDBSA)']"" N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q
I '$D(@DDBSA) N X S X(1)="SOURCE ARRAY("_DDBSA_")" D BLD^DIALOG(202,.X) Q
N DDBRE,DDBLN,DDBRPE,DDBPSA,DDBTO,I,X,Y
N DDBFNO,DDBDM,DDBSF,DDBTL,DDBTPG,DDBZN,DDBFTR,DDBHDR,DDBHDRC,DDBST
S DDBHDR=$$CTXT($G(DDBPMSG,"VA FileMan Browser"),$J("",IOM+1),IOM)
S DDBHDRC=+$G(DDBHDRC)
S DDBTL=$P($G(@DDBSA@(0)),"^",3) S:DDBTL'>0 DDBTL=$O(@DDBSA@(" "),-1)
I DDBTL'>0 D I DDBTL'>0 D BLD^DIALOG(1700,"*NO TEXT* "_DDBSA) Q
.N I S I=0 F S I=$O(@DDBSA@(I)) Q:I'>0 S DDBTL=I
.Q
S DDBZN=$D(@DDBSA@(DDBTL,0))#2,DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1),DDBDM=DDBSA="^TMP(""DDB"",$J)",DDBSF=1
S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)")
S DDBPSA=0,DDBFLG=$G(DDBFLG)
S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL
S (DDBRE,DDBRPE)="",DDBTO=0,DDBST=IOM
S DDBLST=$G(DDBLST,"^TMP(""DDBLST"",$J)"),DDBLN=$S($D(@DDBLST@("A",DDBSA)):^(DDBSA),1:$O(@DDBLST@(" "),-1)+1)
D SAVEDDB^DDBR2(DDBLST,DDBLN,1)
Q
;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
Q:X="" $G(T)
N HW
S W=$G(W,79),HW=W\2
S $E(T,HW-($L(X)\2),HW-($L(X)\2)+$L(X))=X Q T
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
;
CHDR(D) ;Change Header Message in Window Title
;D=direction 1 is down, -1 is up, if 0 restore back to original msg.
N C
S C=DDBHDRC+D
I C<0!(C>DDBTL) W $C(7) Q
S DDBHDRC=C
ENCHDR I 'DDBHDRC S DDBHDR=$$CTXT^DDBR(DDBPMSG,$J("",IOM+1),IOM)
E D
.I DDBZN S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC,0),DDBSF,DDBST)_$J("",IOM+1),"",IOM) Q
.S DDBHDR=$$CTXT^DDBR($E(@DDBSA@(DDBHDRC),DDBSF,DDBST)_$J("",IOM+1),"",IOM)
.Q
I DDBRSA S DDBRSA(DDBRSA,"DDBHDRC")=DDBHDRC,DDBRSA(DDBRSA,"DDBHDR")=DDBHDR
; repaint screen
D RPS^DDBRGE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBR4 2631 printed Dec 13, 2024@02:41:46 Page 2
DDBR4 ;SFISC/DCL-LOAD CURRENT LIST ;NOV 04, 1996@13:49
+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 ;
LOADCL(DDBSA,DDBFLG,DDBPMSG,DDBL,DDBC,DDBLST) ;
+1 ;DDBSA=source array by value
+2 ;DDGFLG=no flags currently available
+3 ;DDBPMSG=text to be displayed (centered) on top line
+4 ;DDBL=display line default 1st screen/line (22 in most cases)
+5 ;DDBC=location of column tab array used with right/left arrow keys
+6 ;DDBLST=location of current list (BROWSER expects ^TMP("DDBLST",$J))
+7 IF $GET(DDBSA)']""
NEW X
SET X(1)="SOURCE ARRAY("_DDBSA_")"
DO BLD^DIALOG(202,.X)
QUIT
+8 IF '$DATA(@DDBSA)
NEW X
SET X(1)="SOURCE ARRAY("_DDBSA_")"
DO BLD^DIALOG(202,.X)
QUIT
+9 NEW DDBRE,DDBLN,DDBRPE,DDBPSA,DDBTO,I,X,Y
+10 NEW DDBFNO,DDBDM,DDBSF,DDBTL,DDBTPG,DDBZN,DDBFTR,DDBHDR,DDBHDRC,DDBST
+11 SET DDBHDR=$$CTXT($GET(DDBPMSG,"VA FileMan Browser"),$JUSTIFY("",IOM+1),IOM)
+12 SET DDBHDRC=+$GET(DDBHDRC)
+13 SET DDBTL=$PIECE($GET(@DDBSA@(0)),"^",3)
if DDBTL'>0
SET DDBTL=$ORDER(@DDBSA@(" "),-1)
+14 IF DDBTL'>0
Begin DoDot:1
+15 NEW I
SET I=0
FOR
SET I=$ORDER(@DDBSA@(I))
if I'>0
QUIT
SET DDBTL=I
+16 QUIT
End DoDot:1
IF DDBTL'>0
DO BLD^DIALOG(1700,"*NO TEXT* "_DDBSA)
QUIT
+17 SET DDBZN=$DATA(@DDBSA@(DDBTL,0))#2
SET DDBTPG=DDBTL\DDBSRL+(DDBTL#DDBSRL'<1)
SET DDBDM=DDBSA="^TMP(""DDB"",$J)"
SET DDBSF=1
+18 SET DDBC=$GET(DDBC,"^TMP(""DDBC"",$J)")
+19 SET DDBPSA=0
SET DDBFLG=$GET(DDBFLG)
+20 SET DDBL=$GET(DDBL,0)
if DDBL<0
SET DDBL=0
if DDBL>DDBTL
SET DDBL=DDBTL
+21 SET (DDBRE,DDBRPE)=""
SET DDBTO=0
SET DDBST=IOM
+22 SET DDBLST=$GET(DDBLST,"^TMP(""DDBLST"",$J)")
SET DDBLN=$SELECT($DATA(@DDBLST@("A",DDBSA)):^(DDBSA),1:$ORDER(@DDBLST@(" "),-1)+1)
+23 DO SAVEDDB^DDBR2(DDBLST,DDBLN,1)
+24 QUIT
+25 ;
CTXT(X,T,W) ;Center X in T which is W characters wide (usually spaces) and W for screen width
+1 if X=""
QUIT $GET(T)
+2 NEW HW
+3 SET W=$GET(W,79)
SET HW=W\2
+4 SET $EXTRACT(T,HW-($LENGTH(X)\2),HW-($LENGTH(X)\2)+$LENGTH(X))=X
QUIT T
OREF(X) NEW X1,X2
SET X1=$PIECE(X,"(")_"("
SET X2=$$OR2($PIECE(X,"(",2))
if X2=""
QUIT X1
QUIT X1_X2_","
OR2(%) if %=")"!(%=",")
QUIT ""
if $LENGTH(%)=1
QUIT %
if "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
+1 ;
CHDR(D) ;Change Header Message in Window Title
+1 ;D=direction 1 is down, -1 is up, if 0 restore back to original msg.
+2 NEW C
+3 SET C=DDBHDRC+D
+4 IF C<0!(C>DDBTL)
WRITE $CHAR(7)
QUIT
+5 SET DDBHDRC=C
ENCHDR IF 'DDBHDRC
SET DDBHDR=$$CTXT^DDBR(DDBPMSG,$JUSTIFY("",IOM+1),IOM)
+1 IF '$TEST
Begin DoDot:1
+2 IF DDBZN
SET DDBHDR=$$CTXT^DDBR($EXTRACT(@DDBSA@(DDBHDRC,0),DDBSF,DDBST)_$JUSTIFY("",IOM+1),"",IOM)
QUIT
+3 SET DDBHDR=$$CTXT^DDBR($EXTRACT(@DDBSA@(DDBHDRC),DDBSF,DDBST)_$JUSTIFY("",IOM+1),"",IOM)
+4 QUIT
End DoDot:1
+5 IF DDBRSA
SET DDBRSA(DDBRSA,"DDBHDRC")=DDBHDRC
SET DDBRSA(DDBRSA,"DDBHDR")=DDBHDR
+6 ; repaint screen
+7 DO RPS^DDBRGE
+8 QUIT
