DDBRU.m

DDBRU ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;2/27/99  11:57

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

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)

 N DESC,RN,RSA,RTN,X,Y

 K ^TMP($J,"DDBDR"),^TMP($J,"DDBDRL"),^UTILITY($J)  ;DR LIST

 X ^%ZOSF("RSEL") Q:$O(^UTILITY($J,""))']""

 S RTN="",RN=1 F  S RTN=$O(^UTILITY($J,RTN)) Q:RTN=""  D

 .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 ^%ZOSF("TEST") I '$T W !,DDBRTN," Invalid",!

 X ^%ZOSF("EON")

 R:$G(DDBRTN)="" !,"Enter Routine> ",DDBRTN:DTIME

 I DDBRTN="" W !,"NO ROUTINE SELECTED",! Q

 S X=DDBRTN X ^%ZOSF("TEST")

 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 ^%ZOSF("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 ^%ZOSF("RM")

 Q

132 W $C(27),"[?",3,$C(104)

 S (IOM,X)=132 X ^%ZOSF("RM")

 Q

DDBRU     ;SFISC/DCL-BROWSER UTILITIES AND EXTRINSIC FUNCTIONS ;2/27/99  11:57

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

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        NEW DESC,RN,RSA,RTN,X,Y

 +2       ;DR LIST

           KILL ^TMP($JOB,"DDBDR"),^TMP($JOB,"DDBDRL"),^UTILITY($JOB)

 +3        XECUTE ^%ZOSF("RSEL")

           IF $ORDER(^UTILITY($JOB,""))']""

               QUIT 

 +4        SET RTN=""

           SET RN=1

           FOR 

               SET RTN=$ORDER(^UTILITY($JOB,RTN))

               IF RTN=""

                   QUIT 

               Begin DoDot:1

 +5                SET DESC=$PIECE($PIECE($TEXT(+1^@RTN),";",2),"-",2)

                   SET DESC=$SELECT($LENGTH(DESC)>45:$EXTRACT(DESC,1,45)_"...",1:DESC)

 +6                SET RSA=$NAME(^TMP($JOB,"DDBDR",RN))

                   SET RN=RN+1

                   SET ^TMP($JOB,"DDBDRL",RTN_$EXTRACT("        ",1,8-$LENGTH(RTN))_": "_DESC)=RSA

 +7                WRITE !,"...loading ",RTN

 +8                DO RTN^DDBRU(RTN,RSA)

 +9                QUIT 

               End DoDot:1

 +10       WRITE !,"...building ""Current List"" tables"

 +11       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 ^%ZOSF("TEST")

               IF '$TEST

                   WRITE !,DDBRTN," Invalid",!

 +6        XECUTE ^%ZOSF("EON")

 +7        IF $GET(DDBRTN)=""

               READ !,"Enter Routine> ",DDBRTN:DTIME

 +8        IF DDBRTN=""

               WRITE !,"NO ROUTINE SELECTED",!

               QUIT 

 +9        SET X=DDBRTN

           XECUTE ^%ZOSF("TEST")

 +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 ^%ZOSF("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 ^%ZOSF("RM")

 +2        QUIT 

132        WRITE $CHAR(27),"[?",3,$CHAR(104)

 +1        SET (IOM,X)=132

           XECUTE ^%ZOSF("RM")

 +2        QUIT