- DDSMSG ;SFISC/MKO - PRINT MESSAGES ;12APR2016
- ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
- ;;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.
- ;;GFT;**75,1055**
- ;
- ERR ;Print "DIERR" messages in help box
- N DDSE,DDSL,DDSLMT,DDSN
- K DDH,DDQ
- S DDSLMT=$G(DDC,15),DDSE=0
- ;
- W $C(7)
- S DDSN=0
- F S DDSN=$O(^TMP("DIERR",$J,DDSN)) Q:'DDSN!DDSE D
- . S DDSL=0
- . F S DDSL=$O(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)) Q:'DDSL!DDSE D
- .. D LD($G(^TMP("DIERR",$J,DDSN,"TEXT",DDSL)),"!")
- .. I DDH'<DDSLMT D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
- ;
- I $G(DDH) S:$G(DDH(1,"T"))?1.C DDH(1,"T")="" D SC^DDSU
- S DDSKM=1
- K DIERR,^TMP("DIERR",$J)
- Q
- ;
- HLP(DDSG) ;Print messages from @DDSG in help area
- N DDSE,DDSL,DDSLMT,DDSNXTF,DDST
- S:$G(DDSG)="" DDSG=$NA(@DDSREFT@("HLP"))
- ;
- K DDH
- I $G(DDQ)-1=DDSHBX,'$X K DDQ
- D:$G(DDQ)>DDSHBX SETDDH
- S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0
- ;
- F S DDSL=$O(@DDSG@(DDSL)) Q:'DDSL!DDSE D
- . S DDST=$G(@DDSG@(DDSL))
- . I DDST="$$EOP" S DDH=$G(DDH)+1,DDH(DDH,"E")=""
- . E D LD(DDST,$G(@DDSG@(DDSL,"F"),"!"))
- . S DDSNXTF=$G(@DDSG@(DDSL+1,"F"),"!")
- . I DDH'<DDSLMT,DDSNXTF["!"!(DDSNXTF'["?") D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
- ;
- I $G(DDH) S:$G(DDH(1,"T"))?1.C DDH(1,"T")="" D SC^DDSU
- K:DDSG=$NA(@DDSREFT@("HLP")) @DDSG
- S:'$D(DDSID) DDSKM=1
- Q
- ;
- WP(DDSR) ;Print the contents of a wp field @DDSR in help area
- N DDSE,DDSL,DDSLMT,DDSNXTF
- ;
- K DDH
- I $G(DDQ)-1=DDSHBX,'$X K DDQ
- D:$G(DDQ)>DDSHBX SETDDH
- S DDSLMT=$G(DDC,15),(DDSE,DDSL)=0
- ;
- F S DDSL=$O(@DDSR@(DDSL)) Q:'DDSL!DDSE D
- . D LD($G(@DDSR@(DDSL,0)),$G(@DDSR@(DDSL,"F"),"!"))
- . S DDSNXTF=$G(@DDSR@(DDSL+1,"F"),"!")
- . I DDH'<DDSLMT,DDSNXTF["!"!(DDSNXTF'["?") D SC^DDSU S:$D(DTOUT)!($D(DUOUT)) DDSE=1
- ;
- I $G(DDH) S:$G(DDH(1,"T"))?1.C DDH(1,"T")="" D SC^DDSU
- S:'$D(DDSID) DDSKM=1
- Q
- ;
- MSG(DDSMSG,DDSFLG,DDSFMT) ;Print local var or array DDSMSG in help area
- ;DDSFLG [ 1 : Write bell
- ;DDSFMT : Format if one line is sent
- N DDSL
- K DDH
- I $G(DDQ)-1=DDSHBX,'$X K DDQ
- D:$G(DDQ)>DDSHBX SETDDH
- ;
- I $D(DDSMSG)=1 D
- . D LD(DDSMSG,$S($G(DDSFMT)]"":DDSFMT,1:"!"))
- ;
- E S DDSL=0 F S DDSL=$O(DDSMSG(DDSL)) Q:'DDSL D
- . D LD($G(DDSMSG(DDSL)),$G(DDSMSG(DDSL,"F"),"!"))
- Q:'$G(DDH)
- ;
- I $G(DDH) D
- . S:$G(DDH(1,"T"))?1.C DDH(1,"T")=""
- . S:$G(DDSFLG)[1 DDH(1,"T")=$C(7)_$G(DDH(1,"T"))
- . D SC^DDSU
- S:'$D(DDSID) DDSKM=1
- Q
- ;
- SETDDH ;Setup DDH and DDQ for identifiers and executable help
- ;that called EN^DDIOL
- S:$X>IOM $X=IOM
- S DDH=1
- S DDH(1,"T")=$TR($J("",$X)," ",$C(0))
- S DDQ=$S(DY>(IOSL-1):IOSL-1,1:DY)-1_U_$X
- Q
- ;
- LD(S,F) ;Load string S with format F into DDH array
- N A,C,J,L
- S DDH=+$G(DDH)
- F J=1:1:$L(F,"!")-1 S DDH=DDH+1,DDH(DDH,"T")=""
- S:'DDH DDH=1
- S:F["?" @("C="_+$P(F,"?",2))
- S L=$G(DDH(DDH,"T"))
- S S=L_$J("",$G(C)-$L(L))_S
- ;
- D WRAP(S,.A,IOM-1)
- S DDH=DDH-1
- F A=1:1:A S DDH=$G(DDH)+1,DDH(DDH,"T")=A(A)
- Q
- ;
- WRAP(L,A,M) ;Wrap line at word boundaries
- ; L = Line of text
- ; M = Margin width
- ;Return:
- ; A = Number of lines
- ; A(n) = Array of text
- ;
- S:'$G(M) M=$S($G(IOM):IOM-5,1:75)
- N I,N
- S N=0
- F I=$L(L," "):-1:1 D Q:L=""
- . I I=1 S N=N+1,A(N)=$E(L,1,M),L=$E(L,M+1,999) Q
- . I $L($P(L," ",1,I))'>M D
- .. S N=N+1,A(N)=$P(L," ",1,I),L=$P(L," ",I+1,999)
- S A=N
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSMSG 3524 printed Jan 18, 2025@03:44:22 Page 2
- DDSMSG ;SFISC/MKO - PRINT MESSAGES ;12APR2016
- +1 ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
- +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 ;;GFT;**75,1055**
- +7 ;
- ERR ;Print "DIERR" messages in help box
- +1 NEW DDSE,DDSL,DDSLMT,DDSN
- +2 KILL DDH,DDQ
- +3 SET DDSLMT=$GET(DDC,15)
- SET DDSE=0
- +4 ;
- +5 WRITE $CHAR(7)
- +6 SET DDSN=0
- +7 FOR
- SET DDSN=$ORDER(^TMP("DIERR",$JOB,DDSN))
- if 'DDSN!DDSE
- QUIT
- Begin DoDot:1
- +8 SET DDSL=0
- +9 FOR
- SET DDSL=$ORDER(^TMP("DIERR",$JOB,DDSN,"TEXT",DDSL))
- if 'DDSL!DDSE
- QUIT
- Begin DoDot:2
- +10 DO LD($GET(^TMP("DIERR",$JOB,DDSN,"TEXT",DDSL)),"!")
- +11 IF DDH'<DDSLMT
- DO SC^DDSU
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET DDSE=1
- End DoDot:2
- End DoDot:1
- +12 ;
- +13 IF $GET(DDH)
- if $GET(DDH(1,"T"))?1.C
- SET DDH(1,"T")=""
- DO SC^DDSU
- +14 SET DDSKM=1
- +15 KILL DIERR,^TMP("DIERR",$JOB)
- +16 QUIT
- +17 ;
- HLP(DDSG) ;Print messages from @DDSG in help area
- +1 NEW DDSE,DDSL,DDSLMT,DDSNXTF,DDST
- +2 if $GET(DDSG)=""
- SET DDSG=$NAME(@DDSREFT@("HLP"))
- +3 ;
- +4 KILL DDH
- +5 IF $GET(DDQ)-1=DDSHBX
- IF '$X
- KILL DDQ
- +6 if $GET(DDQ)>DDSHBX
- DO SETDDH
- +7 SET DDSLMT=$GET(DDC,15)
- SET (DDSE,DDSL)=0
- +8 ;
- +9 FOR
- SET DDSL=$ORDER(@DDSG@(DDSL))
- if 'DDSL!DDSE
- QUIT
- Begin DoDot:1
- +10 SET DDST=$GET(@DDSG@(DDSL))
- +11 IF DDST="$$EOP"
- SET DDH=$GET(DDH)+1
- SET DDH(DDH,"E")=""
- +12 IF '$TEST
- DO LD(DDST,$GET(@DDSG@(DDSL,"F"),"!"))
- +13 SET DDSNXTF=$GET(@DDSG@(DDSL+1,"F"),"!")
- +14 IF DDH'<DDSLMT
- IF DDSNXTF["!"!(DDSNXTF'["?")
- DO SC^DDSU
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET DDSE=1
- End DoDot:1
- +15 ;
- +16 IF $GET(DDH)
- if $GET(DDH(1,"T"))?1.C
- SET DDH(1,"T")=""
- DO SC^DDSU
- +17 if DDSG=$NAME(@DDSREFT@("HLP"))
- KILL @DDSG
- +18 if '$DATA(DDSID)
- SET DDSKM=1
- +19 QUIT
- +20 ;
- WP(DDSR) ;Print the contents of a wp field @DDSR in help area
- +1 NEW DDSE,DDSL,DDSLMT,DDSNXTF
- +2 ;
- +3 KILL DDH
- +4 IF $GET(DDQ)-1=DDSHBX
- IF '$X
- KILL DDQ
- +5 if $GET(DDQ)>DDSHBX
- DO SETDDH
- +6 SET DDSLMT=$GET(DDC,15)
- SET (DDSE,DDSL)=0
- +7 ;
- +8 FOR
- SET DDSL=$ORDER(@DDSR@(DDSL))
- if 'DDSL!DDSE
- QUIT
- Begin DoDot:1
- +9 DO LD($GET(@DDSR@(DDSL,0)),$GET(@DDSR@(DDSL,"F"),"!"))
- +10 SET DDSNXTF=$GET(@DDSR@(DDSL+1,"F"),"!")
- +11 IF DDH'<DDSLMT
- IF DDSNXTF["!"!(DDSNXTF'["?")
- DO SC^DDSU
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET DDSE=1
- End DoDot:1
- +12 ;
- +13 IF $GET(DDH)
- if $GET(DDH(1,"T"))?1.C
- SET DDH(1,"T")=""
- DO SC^DDSU
- +14 if '$DATA(DDSID)
- SET DDSKM=1
- +15 QUIT
- +16 ;
- MSG(DDSMSG,DDSFLG,DDSFMT) ;Print local var or array DDSMSG in help area
- +1 ;DDSFLG [ 1 : Write bell
- +2 ;DDSFMT : Format if one line is sent
- +3 NEW DDSL
- +4 KILL DDH
- +5 IF $GET(DDQ)-1=DDSHBX
- IF '$X
- KILL DDQ
- +6 if $GET(DDQ)>DDSHBX
- DO SETDDH
- +7 ;
- +8 IF $DATA(DDSMSG)=1
- Begin DoDot:1
- +9 DO LD(DDSMSG,$SELECT($GET(DDSFMT)]"":DDSFMT,1:"!"))
- End DoDot:1
- +10 ;
- +11 IF '$TEST
- SET DDSL=0
- FOR
- SET DDSL=$ORDER(DDSMSG(DDSL))
- if 'DDSL
- QUIT
- Begin DoDot:1
- +12 DO LD($GET(DDSMSG(DDSL)),$GET(DDSMSG(DDSL,"F"),"!"))
- End DoDot:1
- +13 if '$GET(DDH)
- QUIT
- +14 ;
- +15 IF $GET(DDH)
- Begin DoDot:1
- +16 if $GET(DDH(1,"T"))?1.C
- SET DDH(1,"T")=""
- +17 if $GET(DDSFLG)[1
- SET DDH(1,"T")=$CHAR(7)_$GET(DDH(1,"T"))
- +18 DO SC^DDSU
- End DoDot:1
- +19 if '$DATA(DDSID)
- SET DDSKM=1
- +20 QUIT
- +21 ;
- SETDDH ;Setup DDH and DDQ for identifiers and executable help
- +1 ;that called EN^DDIOL
- +2 if $X>IOM
- SET $X=IOM
- +3 SET DDH=1
- +4 SET DDH(1,"T")=$TRANSLATE($JUSTIFY("",$X)," ",$CHAR(0))
- +5 SET DDQ=$SELECT(DY>(IOSL-1):IOSL-1,1:DY)-1_U_$X
- +6 QUIT
- +7 ;
- LD(S,F) ;Load string S with format F into DDH array
- +1 NEW A,C,J,L
- +2 SET DDH=+$GET(DDH)
- +3 FOR J=1:1:$LENGTH(F,"!")-1
- SET DDH=DDH+1
- SET DDH(DDH,"T")=""
- +4 if 'DDH
- SET DDH=1
- +5 if F["?"
- SET @("C="_+$PIECE(F,"?",2))
- +6 SET L=$GET(DDH(DDH,"T"))
- +7 SET S=L_$JUSTIFY("",$GET(C)-$LENGTH(L))_S
- +8 ;
- +9 DO WRAP(S,.A,IOM-1)
- +10 SET DDH=DDH-1
- +11 FOR A=1:1:A
- SET DDH=$GET(DDH)+1
- SET DDH(DDH,"T")=A(A)
- +12 QUIT
- +13 ;
- WRAP(L,A,M) ;Wrap line at word boundaries
- +1 ; L = Line of text
- +2 ; M = Margin width
- +3 ;Return:
- +4 ; A = Number of lines
- +5 ; A(n) = Array of text
- +6 ;
- +7 if '$GET(M)
- SET M=$SELECT($GET(IOM):IOM-5,1:75)
- +8 NEW I,N
- +9 SET N=0
- +10 FOR I=$LENGTH(L," "):-1:1
- Begin DoDot:1
- +11 IF I=1
- SET N=N+1
- SET A(N)=$EXTRACT(L,1,M)
- SET L=$EXTRACT(L,M+1,999)
- QUIT
- +12 IF $LENGTH($PIECE(L," ",1,I))'>M
- Begin DoDot:2
- +13 SET N=N+1
- SET A(N)=$PIECE(L," ",1,I)
- SET L=$PIECE(L," ",I+1,999)
- End DoDot:2
- End DoDot:1
- if L=""
- QUIT
- +14 SET A=N
- +15 QUIT