DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;19JAN2013
;;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.
;
CTRLCH() ;Extrinsic function - returns control characters 1-31
N I,X S X="" N I F I=1:1:31 S X=X_$C(I)
Q X
;
COL(DDBC) ;Set up colums used by Fileman Print Set DIOEND="D COL^DDBRU()" when calling Browser
N H,I,P,Q,T,X
S DDBC=$G(DDBC,"^TMP(""DDBC"",$J)")
I $D(^TMP("DDBC",$J)) K ^($J)
S X=0 F S X=$O(^UTILITY($J,99,X)) Q:X'>0 S T=^(X) D
.S:T["D ^" H=$P(T,"^",2)
.S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)=""
.Q
I $G(H)]"" F X=1:1 S T=$T(@"HEAD"+X^@H) Q:T="" D
.S Q=$L(T,"?") I Q>1 F I=1:1:Q S P=+$P(T,"?",I)+1 S @DDBC@(P)=""
.Q
Q
;
KTMP K ^TMP("DDB",$J),^TMP("DDBC",$J)
K ^TMP("DDBLST",$J)
Q
;
TRMERR(DDGLCH) ;Terminal type errors
N P
S P(1)=DDGLCH,P(2)=IOST
D BLD^DIALOG(842,.P)
Q
;
RTN(RTN,TMPGBL) ;
N I,F,X
F I=1:1 S X=$T(+I^@RTN) Q:X="" S F=$F(X," ")-1,$E(X,F)=$E(" ",1,$S(F'>8:8-F,1:1)),@TMPGBL@(I)=$TR(X,$C(9)," ")
Q
;
RTNTB(DDBRTOP,DDBRBOT) ;PASS TOP AND BOTTOM MARGINS
G DR
;
ENDR N DDBENDR S DDBENDR=1
;
DR ;Display Routine(s)
D:'$D(DISYS) OS^DII
N DESC,RN,RSA,RTN,X,Y
K ^TMP($J,"DDBDR"),^TMP($J,"DDBDRL"),^UTILITY($J) ;DR LIST
X ^DD("OS",DISYS,"RSEL") Q:$O(^UTILITY($J,""))']""
S RTN=" ",RN=1 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" D ; VEN/SMH - Make starting point " " for RTN so it won't crash on Cache
.S DESC=$P($P($T(+1^@RTN),";",2),"-",2),DESC=$S($L(DESC)>45:$E(DESC,1,45)_"...",1:DESC)
.S RSA=$NA(^TMP($J,"DDBDR",RN)),RN=RN+1,^TMP($J,"DDBDRL",RTN_$E(" ",1,8-$L(RTN))_": "_DESC)=RSA
.W !,"...loading ",RTN
.D RTN^DDBRU(RTN,RSA)
.Q
W !,"...building ""Current List"" tables"
D DOCLIST^DDBR("^TMP($J,""DDBDRL"")","",$G(DDBRTOP),$G(DDBRBOT))
K K ^TMP($J,"DDBDRL"),^TMP($J,"DDBDR"),^UTILITY($J)
Q
;
OUT ;
D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
D:$G(DDBFLG)'["P" KTMP
Q
;
RE(DDBRTN) G EDIT
RTNEDIT N DDBRTN
EDIT ;ROUTINE EDIT VIA VA FILEMAN SCREEN EDITOR
;EITHER PASS ROUTINE NAME RE^DDBRU("ROUTINE_NAME") OR USE
;RTNEDIT^DDBRU AND BE PROMPTED FOR ROUTINE NAME
I '$D(^DD("OS",^DD("OS"),"ZS")) W !,"ROUTINE SAVE NODE NOT DEFINED IN MUMPS OPERATING SYSTEM FILE",! Q
N DDBRI,DDBRX,X,Y,%,%X,%Y
I $G(DDBRTN)]"" S X=DDBRTN X ^DD("OS",^DD("OS"),18) I '$T W !,DDBRTN," Invalid",!
X ^DD("OS",^DD("OS"),"EON")
R:$G(DDBRTN)="" !,"Enter Routine> ",DDBRTN:DTIME
I DDBRTN="" W !,"NO ROUTINE SELECTED",! Q
S X=DDBRTN X ^DD("OS",^DD("OS"),18)
I '$T W !,"NO SUCH ROUTINE",! Q
K ^TMP("DDBRTN",$J)
W !,"Loading ",DDBRTN
F DDBRI=1:1 S DDBRX=$T(+DDBRI^@DDBRTN) Q:DDBRX="" S ^TMP("DDBRTN",$J,DDBRI)=$$SP(DDBRX)
D EDIT^DDW("^TMP(""DDBRTN"",$J)","M",DDBRTN,"Routine: "_DDBRTN)
K ^UTILITY($J,0)
S DDBRI=0,$P(^TMP("DDBRTN",$J,1),";",3)=$$NOW
F S DDBRI=$O(^TMP("DDBRTN",$J,DDBRI)) Q:DDBRI'>0 S ^UTILITY($J,0,DDBRI)=$$TAB(^(DDBRI))
S X=DDBRTN
X ^DD("OS",^DD("OS"),"ZS")
K ^TMP("DDBRTN",$J),^UTILITY($J,0)
X ^DD("OS",^DD("OS"),"EON")
Q
TAB(X) ;CONVERT 1ST SPACE TO TAB IF NO TAB
N E,L,T
S X=$G(X)
Q:X="" ""
S T=$C(9)
Q:$E(X)=T X
S L=$L(X)
F E=1:1:L Q:$E(X,E)=T I $E(X,E)=" " S $E(X,E)=T D Q
.S E=E+1
.F Q:$E(X,E)'=" " S $E(X,E)=""
.Q
Q X
;
SP(X) ;MAKE SURE A TAB OR 1ST SPACE IS SET TO SPACES
N E,L,S,SPS,T
S X=$G(X)
Q:X="" ""
S S=8,$P(SPS," ",S)=" ",T=$E(9)
I $E(X)=T S $E(X)=" " ;Q " "_X
S L=$L(X)
F E=1:1:L I $E(X,E)=" " D S $E(X,E)=$E(SPS,1,S-(E#S)) Q
.S E=E+1
.F Q:$E(X,E)'=" " S $E(X,E)=""
.S E=E-1
.Q
Q X
;
NOW() ;
N %DT,X,Y
S %DT="T",X="NOW"
D ^%DT
Q $$FMTE^DILIBF(Y,"1U")
;
MSMCON ;MSM CONSOLE FOR 132/80 MODES
;OR VT TERMINALS
80 W $C(27),"[?",3,$C(108)
S (IOM,X)=80 X ^DD("OS",^DD("OS"),"RM")
Q
132 W $C(27),"[?",3,$C(104)
S (IOM,X)=132 X ^DD("OS",^DD("OS"),"RM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBRU 4122 printed Sep 11, 2024@03:01:46 Page 2
DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;19JAN2013
+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 ;
CTRLCH() ;Extrinsic function - returns control characters 1-31
+1 NEW I,X
SET X=""
NEW I
FOR I=1:1:31
SET X=X_$CHAR(I)
+2 QUIT X
+3 ;
COL(DDBC) ;Set up colums used by Fileman Print Set DIOEND="D COL^DDBRU()" when calling Browser
+1 NEW H,I,P,Q,T,X
+2 SET DDBC=$GET(DDBC,"^TMP(""DDBC"",$J)")
+3 IF $DATA(^TMP("DDBC",$JOB))
KILL ^($JOB)
+4 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,99,X))
if X'>0
QUIT
SET T=^(X)
Begin DoDot:1
+5 if T["D ^"
SET H=$PIECE(T,"^",2)
+6 SET Q=$LENGTH(T,"?")
IF Q>1
FOR I=1:1:Q
SET P=+$PIECE(T,"?",I)+1
SET @DDBC@(P)=""
+7 QUIT
End DoDot:1
+8 IF $GET(H)]""
FOR X=1:1
SET T=$TEXT(@"HEAD"+X^@H)
if T=""
QUIT
Begin DoDot:1
+9 SET Q=$LENGTH(T,"?")
IF Q>1
FOR I=1:1:Q
SET P=+$PIECE(T,"?",I)+1
SET @DDBC@(P)=""
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
KTMP KILL ^TMP("DDB",$JOB),^TMP("DDBC",$JOB)
+1 KILL ^TMP("DDBLST",$JOB)
+2 QUIT
+3 ;
TRMERR(DDGLCH) ;Terminal type errors
+1 NEW P
+2 SET P(1)=DDGLCH
SET P(2)=IOST
+3 DO BLD^DIALOG(842,.P)
+4 QUIT
+5 ;
RTN(RTN,TMPGBL) ;
+1 NEW I,F,X
+2 FOR I=1:1
SET X=$TEXT(+I^@RTN)
if X=""
QUIT
SET F=$FIND(X," ")-1
SET $EXTRACT(X,F)=$EXTRACT(" ",1,$SELECT(F'>8:8-F,1:1))
SET @TMPGBL@(I)=$TRANSLATE(X,$CHAR(9)," ")
+3 QUIT
+4 ;
RTNTB(DDBRTOP,DDBRBOT) ;PASS TOP AND BOTTOM MARGINS
+1 GOTO DR
+2 ;
ENDR NEW DDBENDR
SET DDBENDR=1
+1 ;
DR ;Display Routine(s)
+1 if '$DATA(DISYS)
DO OS^DII
+2 NEW DESC,RN,RSA,RTN,X,Y
+3 ;DR LIST
KILL ^TMP($JOB,"DDBDR"),^TMP($JOB,"DDBDRL"),^UTILITY($JOB)
+4 XECUTE ^DD("OS",DISYS,"RSEL")
if $ORDER(^UTILITY($JOB,""))']""
QUIT
+5 ; VEN/SMH - Make starting point " " for RTN so it won't crash on Cache
SET RTN=" "
SET RN=1
FOR
SET RTN=$ORDER(^UTILITY($JOB,RTN))
if RTN=""
QUIT
Begin DoDot:1
+6 SET DESC=$PIECE($PIECE($TEXT(+1^@RTN),";",2),"-",2)
SET DESC=$SELECT($LENGTH(DESC)>45:$EXTRACT(DESC,1,45)_"...",1:DESC)
+7 SET RSA=$NAME(^TMP($JOB,"DDBDR",RN))
SET RN=RN+1
SET ^TMP($JOB,"DDBDRL",RTN_$EXTRACT(" ",1,8-$LENGTH(RTN))_": "_DESC)=RSA
+8 WRITE !,"...loading ",RTN
+9 DO RTN^DDBRU(RTN,RSA)
+10 QUIT
End DoDot:1
+11 WRITE !,"...building ""Current List"" tables"
+12 DO DOCLIST^DDBR("^TMP($J,""DDBDRL"")","",$GET(DDBRTOP),$GET(DDBRBOT))
K KILL ^TMP($JOB,"DDBDRL"),^TMP($JOB,"DDBDR"),^UTILITY($JOB)
+1 QUIT
+2 ;
OUT ;
+1 if '$DATA(DDS)
DO KILL^DDGLIB0($GET(DDBFLG))
+2 if $GET(DDBFLG)'["P"
DO KTMP
+3 QUIT
+4 ;
RE(DDBRTN) GOTO EDIT
RTNEDIT NEW DDBRTN
EDIT ;ROUTINE EDIT VIA VA FILEMAN SCREEN EDITOR
+1 ;EITHER PASS ROUTINE NAME RE^DDBRU("ROUTINE_NAME") OR USE
+2 ;RTNEDIT^DDBRU AND BE PROMPTED FOR ROUTINE NAME
+3 IF '$DATA(^DD("OS",^DD("OS"),"ZS"))
WRITE !,"ROUTINE SAVE NODE NOT DEFINED IN MUMPS OPERATING SYSTEM FILE",!
QUIT
+4 NEW DDBRI,DDBRX,X,Y,%,%X,%Y
+5 IF $GET(DDBRTN)]""
SET X=DDBRTN
XECUTE ^DD("OS",^DD("OS"),18)
IF '$TEST
WRITE !,DDBRTN," Invalid",!
+6 XECUTE ^DD("OS",^DD("OS"),"EON")
+7 if $GET(DDBRTN)=""
READ !,"Enter Routine> ",DDBRTN:DTIME
+8 IF DDBRTN=""
WRITE !,"NO ROUTINE SELECTED",!
QUIT
+9 SET X=DDBRTN
XECUTE ^DD("OS",^DD("OS"),18)
+10 IF '$TEST
WRITE !,"NO SUCH ROUTINE",!
QUIT
+11 KILL ^TMP("DDBRTN",$JOB)
+12 WRITE !,"Loading ",DDBRTN
+13 FOR DDBRI=1:1
SET DDBRX=$TEXT(+DDBRI^@DDBRTN)
if DDBRX=""
QUIT
SET ^TMP("DDBRTN",$JOB,DDBRI)=$$SP(DDBRX)
+14 DO EDIT^DDW("^TMP(""DDBRTN"",$J)","M",DDBRTN,"Routine: "_DDBRTN)
+15 KILL ^UTILITY($JOB,0)
+16 SET DDBRI=0
SET $PIECE(^TMP("DDBRTN",$JOB,1),";",3)=$$NOW
+17 FOR
SET DDBRI=$ORDER(^TMP("DDBRTN",$JOB,DDBRI))
if DDBRI'>0
QUIT
SET ^UTILITY($JOB,0,DDBRI)=$$TAB(^(DDBRI))
+18 SET X=DDBRTN
+19 XECUTE ^DD("OS",^DD("OS"),"ZS")
+20 KILL ^TMP("DDBRTN",$JOB),^UTILITY($JOB,0)
+21 XECUTE ^DD("OS",^DD("OS"),"EON")
+22 QUIT
TAB(X) ;CONVERT 1ST SPACE TO TAB IF NO TAB
+1 NEW E,L,T
+2 SET X=$GET(X)
+3 if X=""
QUIT ""
+4 SET T=$CHAR(9)
+5 if $EXTRACT(X)=T
QUIT X
+6 SET L=$LENGTH(X)
+7 FOR E=1:1:L
if $EXTRACT(X,E)=T
QUIT
IF $EXTRACT(X,E)=" "
SET $EXTRACT(X,E)=T
Begin DoDot:1
+8 SET E=E+1
+9 FOR
if $EXTRACT(X,E)'=" "
QUIT
SET $EXTRACT(X,E)=""
+10 QUIT
End DoDot:1
QUIT
+11 QUIT X
+12 ;
SP(X) ;MAKE SURE A TAB OR 1ST SPACE IS SET TO SPACES
+1 NEW E,L,S,SPS,T
+2 SET X=$GET(X)
+3 if X=""
QUIT ""
+4 SET S=8
SET $PIECE(SPS," ",S)=" "
SET T=$EXTRACT(9)
+5 ;Q " "_X
IF $EXTRACT(X)=T
SET $EXTRACT(X)=" "
+6 SET L=$LENGTH(X)
+7 FOR E=1:1:L
IF $EXTRACT(X,E)=" "
Begin DoDot:1
+8 SET E=E+1
+9 FOR
if $EXTRACT(X,E)'=" "
QUIT
SET $EXTRACT(X,E)=""
+10 SET E=E-1
+11 QUIT
End DoDot:1
SET $EXTRACT(X,E)=$EXTRACT(SPS,1,S-(E#S))
QUIT
+12 QUIT X
+13 ;
NOW() ;
+1 NEW %DT,X,Y
+2 SET %DT="T"
SET X="NOW"
+3 DO ^%DT
+4 QUIT $$FMTE^DILIBF(Y,"1U")
+5 ;
MSMCON ;MSM CONSOLE FOR 132/80 MODES
+1 ;OR VT TERMINALS
80 WRITE $CHAR(27),"[?",3,$CHAR(108)
+1 SET (IOM,X)=80
XECUTE ^DD("OS",^DD("OS"),"RM")
+2 QUIT
132 WRITE $CHAR(27),"[?",3,$CHAR(104)
+1 SET (IOM,X)=132
XECUTE ^DD("OS",^DD("OS"),"RM")
+2 QUIT
