DIALOG ;SFISC/TKW - BUILD FILEMAN DIALOGUE ;10:29 AM 14 May 2001 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
V ;;22.0;VA FileMan;**28,87**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
BLD(D0,DIPI,DIPE,DIALOGO,DIFLAG) ;BUILD FILEMAN DIALOG
;1)DIALOG file IEN, 2)Internal params, 3)External params, 4)Output array name, 5)S=Suppress blank line between messages, F=Format output like ^TMP
N DINAKED S DINAKED=$$LGR^%ZOSV
I $G(^DI(.84,+$G(D0),0))="" G Q1
N E,I,J,K,L,M,N,P,R,S,X,O,DILANG S DILANG=+$G(DUZ("LANG")),DIFLAG=$G(DIFLAG)
I $G(DIPE)]"",$O(DIPE(""))="" S DIPE(1)=DIPE
I '$O(^DI(.84,D0,4,DILANG,1,0))!('DILANG) S DILANG=1
S P=$P(^DI(.84,+D0,0),U,3)["y",R=$P(^(0),U,2) S:'R R=1
S O=$G(DIALOGO) S:O="" O="^TMP(",DIFLAG=DIFLAG_"F" D S DIALOGO=O
. S I=$E(O,$L(O)) I $E(O,1,4)="DIR(" S DIFLAG=$TR(DIFLAG,"F","")
. I DIFLAG'["F" S O=$E(O,1,($L(O)-1))_$S(I="(":"",I=",":")",1:I) Q
. S O=$P(O,")",1)_$S("(,"[I:"",O'["(":"(",1:",")_""""_$P("DIERR^DIMSG^DIHELP",U,R)_""""_$P(","_$J,U,O["^TMP(")_")"
. Q
S N=$O(@DIALOGO@(":"),-1)
S N=N+1,(I,J,M)=0 S:R>1!(DIFLAG'["F") J=N-1
I R=1,DIFLAG["F" S O=$P(O,")",1)_","_N_",""TEXT"")"
I DILANG>1 F S I=$O(^DI(.84,D0,4,DILANG,1,I)) Q:'I S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM
I DILANG'>1 F S I=$O(^DI(.84,D0,2,I)) Q:'I S M=M+1,K(M)=$G(^(I,0)) I P S L=0 D PARAM
G:'M Q2 D
. N X S X=M
. I N>1,DIFLAG'["S" I DIFLAG'["F"!(R>1) S J=J+1,@O@(J)=" ",X=X+1
. I DIALOGO'["DIR" S:R=1 DIERR=($P($G(DIERR),U)+1)_U_($P($G(DIERR),U,2)+X) S:R=2 DIMSG=$G(DIMSG)+X S:R=3 DIHELP=$G(DIHELP)+X
. D BTXT Q
I (DIALOGO["DIR")!(R'=1)!(DIFLAG'["F") G Q2
S @DIALOGO@(N)=D0
S I="",J=0 F S I=$O(DIPE(I)) Q:I="" I $G(DIPE(I))]"" S @DIALOGO@(N,"PARAM",I)=DIPE(I),J=J+1
I J S @DIALOGO@(N,"PARAM",0)=J
S @DIALOGO@("E",D0,N)=""
;
Q2 I $G(^DI(.84,D0,6))]"" X ^(6)
Q1 Q:DINAKED="" I DINAKED["(" Q:$O(@(DINAKED))]"" Q
I $D(@(DINAKED))
Q
;
PARAM S S=$F(K(M),"|",L) G:'S QP S E=$F(K(M),"|",S) G:'E QP
S X=$E(K(M),S,E-2) G:X="" PARAM
S DIPI(X)=$S($G(DIPI(X))]"":DIPI(X),1:$G(DIPI)),L=S+$L(DIPI(X))-$L(X)
I ($L(K(M))+$L(DIPI(X)))<245 S K(M)=$E(K(M),1,S-2)_DIPI(X)_$E(K(M),E,9999) G:K(M)]"" PARAM K K(M) S M=M-1 G QP
I $L($E(K(M),1,S-2))+$L(DIPI(X))<245 S K(M+1)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2)_DIPI(X),M=M+1,L=0 G PARAM
I $L(DIPI(X))+$L($E(K(M),E,9999))<245 S K(M+1)=DIPI(X)_$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+1,L=0 G PARAM
S K(M+1)=DIPI(X),K(M+2)=$E(K(M),E,9999),K(M)=$E(K(M),1,S-2),M=M+2,L=0
G PARAM
QP Q
;
BTXT N M
F M=0:0 S M=$O(K(M)) Q:'M S J=J+1 D
.I DIALOGO'["DIR" S @O@(J)=K(M) Q
.I '$O(K(M)),'$O(^DI(.84,D0,2,I)) S @DIALOGO=K(M) Q
.S @DIALOGO@(J)=K(M) Q
Q
;
EZBLD(D0,DIPI) ;RETURN SINGLE LINE OF TEXT FROM DIALOG FILE.
;D0 = DIALOG file IEN, DIPI = Input Params
N DINAKED S DINAKED=$$LGR^%ZOSV I $G(^DI(.84,+$G(D0),0))="" D Q1 Q ""
N DILANG S DILANG=+$G(DUZ("LANG"))
N X I DILANG>1 S X=$O(^DI(.84,+D0,4,DILANG,1,0)) S:X X=$G(^(X,0))
I $G(X)']"" S X=$O(^DI(.84,+D0,2,0)) S:X X=$G(^(X,0))
I ($P(^DI(.84,+D0,0),"^",3)'["y"!($G(X)="")) S X=$G(X) G QEZ
N K,S,L,M,I,E S M=1,L=0,K(M)=X
I $G(DIPI)]"",$O(DIPI(""))="" S DIPI(1)=DIPI
D PARAM S X=$G(K(1))
QEZ D Q X
. N X D Q2 Q
;
;
MSG(DIFLGS,DIOUT,DIMARGIN,DICOLUMN,DIINNAME) ;WRITE MESSAGES OR MOVE THEM TO SIMPLE ARRAY.
;1)Flags, 2)Output array name, 3)Margin width of text, 4)Starting column no., 5)Input array name.
N Z,%,X,Y,I,J,K,N,DITYP,DIWIDTH,DITMP,DIIN,DINAKED S DINAKED=$$LGR^%ZOSV
S:$G(DIFLGS)="" DIFLGS="W" D
. S DITMP=0 I $G(DIINNAME)="" S DIINNAME="^TMP(",DITMP=1 Q
. N % S %=DIINNAME I %'["(" S DIINNAME=DIINNAME_"(" Q
. Q:$E(%,$L(%))=","
. I $E(%,$L(%))=")" S DIINNAME=$P(%,")",1)_"," Q
. S DIINNAME=%_"," Q
S DITYP="",%=0 D
. F Z="E","H","M" S %=%+1 I DIFLGS[Z,$D(@(DIINNAME_""""_$P("DIERR^DIHELP^DIMSG",U,%)_""""_$P(","_$J,U,(DITMP>0))_")")) S $P(DITYP,U,%)=$P("DIERR^DIHELP^DIMSG",U,%)
. I DITYP="",$D(@(DIINNAME_"""DIERR"""_$P(","_$J,U,(DITMP>0))_")")) S DITYP="DIERR"
. Q
S DIWIDTH=$S($G(DIMARGIN):DIMARGIN,$G(IOM):(IOM-5),1:75),DICOLUMN=+$G(DICOLUMN)
K:DIFLGS["A" DIOUT S (K,Z)=0
AWS S K=K+1 I K>3 G Q1
G:$P(DITYP,U,K)="" AWS
S DIIN=DIINNAME_""""_$P(DITYP,U,K)_"""" S:DITMP DIIN=DIIN_","_$J
S (I,N)=0
F S N=$O(@(DIIN_")")@(N)) Q:'N S:K>1 X=$G(@(DIIN_","_N_")")) D:K>1 I K=1 D:I&(DIFLGS'["B") LN S I=1,J=0 F S J=$O(@(DIIN_")")@(N,"TEXT",J)) Q:'J S X=$G(@(DIIN_","_N_",""TEXT"","_J_")")) D
. I DIFLGS["A",'$G(DIMARGIN) S Z=Z+1,DIOUT(Z)=X
. I DIFLGS'["W",'$G(DIMARGIN) Q
. S Y=X D:X="" F Q:X="" F %=$L(X," "):-1:1 S:%=1&($L($P(X," ",1,%))>DIWIDTH) X=$E(X,1,(DIWIDTH-1))_" "_$E(X,DIWIDTH,$L(X)),%=%+1 I $L($P(X," ",1,%))'>DIWIDTH S Y=$P(X," ",1,%) D S X=$P(X," ",%+1,$L(X," ")) Q
.. W:DIFLGS["W" !?DICOLUMN,Y S:DIFLGS["A"&$G(DIMARGIN) Z=Z+1,DIOUT(Z)=Y
.. Q
. Q
F I=K:1:2 I $P(DITYP,U,I+1)]"" D LN Q
I DIFLGS["A",DIFLGS["T" S DIOUT=Z
I DIFLGS'["S" K @(DIIN_")"),@($P(DITYP,U,K))
G AWS
;
LN W:DIFLGS["W" ! S:(DIFLGS["A")&Z Z=Z+1,DIOUT(Z)="" Q
DIALOG ;SFISC/TKW - BUILD FILEMAN DIALOGUE ;10:29 AM 14 May 2001 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
V ;;22.0;VA FileMan;**28,87**;Mar 30, 1999
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
BLD(D0,DIPI,DIPE,DIALOGO,DIFLAG) ;BUILD FILEMAN DIALOG
+1 ;1)DIALOG file IEN, 2)Internal params, 3)External params, 4)Output array name, 5)S=Suppress blank line between messages, F=Format output like ^TMP
+2 NEW DINAKED
SET DINAKED=$$LGR^%ZOSV
+3 IF $GET(^DI(.84,+$GET(D0),0))=""
GOTO Q1
+4 NEW E,I,J,K,L,M,N,P,R,S,X,O,DILANG
SET DILANG=+$GET(DUZ("LANG"))
SET DIFLAG=$GET(DIFLAG)
+5 IF $GET(DIPE)]""
IF $ORDER(DIPE(""))=""
SET DIPE(1)=DIPE
+6 IF '$ORDER(^DI(.84,D0,4,DILANG,1,0))!('DILANG)
SET DILANG=1
+7 SET P=$PIECE(^DI(.84,+D0,0),U,3)["y"
SET R=$PIECE(^(0),U,2)
IF 'R
SET R=1
+8 SET O=$GET(DIALOGO)
IF O=""
SET O="^TMP("
SET DIFLAG=DIFLAG_"F"
Begin DoDot:1
+9 SET I=$EXTRACT(O,$LENGTH(O))
IF $EXTRACT(O,1,4)="DIR("
SET DIFLAG=$TRANSLATE(DIFLAG,"F","")
+10 IF DIFLAG'["F"
SET O=$EXTRACT(O,1,($LENGTH(O)-1))_$SELECT(I="(":"",I=",":")",1:I)
QUIT
+11 SET O=$PIECE(O,")",1)_$SELECT("(,"[I:"",O'["(":"(",1:",")_""""_$PIECE("DIERR^DIMSG^DIHELP",U,R)_""""_$PIECE(","_$JOB,U,O["^TMP(")_")"
+12 QUIT
End DoDot:1
SET DIALOGO=O
+13 SET N=$ORDER(@DIALOGO@(":"),-1)
+14 SET N=N+1
SET (I,J,M)=0
IF R>1!(DIFLAG'["F")
SET J=N-1
+15 IF R=1
IF DIFLAG["F"
SET O=$PIECE(O,")",1)_","_N_",""TEXT"")"
+16 IF DILANG>1
FOR
SET I=$ORDER(^DI(.84,D0,4,DILANG,1,I))
IF 'I
QUIT
SET M=M+1
SET K(M)=$GET(^(I,0))
IF P
SET L=0
DO PARAM
+17 IF DILANG'>1
FOR
SET I=$ORDER(^DI(.84,D0,2,I))
IF 'I
QUIT
SET M=M+1
SET K(M)=$GET(^(I,0))
IF P
SET L=0
DO PARAM
+18 IF 'M
GOTO Q2
Begin DoDot:1
+19 NEW X
SET X=M
+20 IF N>1
IF DIFLAG'["S"
IF DIFLAG'["F"!(R>1)
SET J=J+1
SET @O@(J)=" "
SET X=X+1
+21 IF DIALOGO'["DIR"
IF R=1
SET DIERR=($PIECE($GET(DIERR),U)+1)_U_($PIECE($GET(DIERR),U,2)+X)
IF R=2
SET DIMSG=$GET(DIMSG)+X
IF R=3
SET DIHELP=$GET(DIHELP)+X
+22 DO BTXT
QUIT
End DoDot:1
+23 IF (DIALOGO["DIR")!(R'=1)!(DIFLAG'["F")
GOTO Q2
+24 SET @DIALOGO@(N)=D0
+25 SET I=""
SET J=0
FOR
SET I=$ORDER(DIPE(I))
IF I=""
QUIT
IF $GET(DIPE(I))]""
SET @DIALOGO@(N,"PARAM",I)=DIPE(I)
SET J=J+1
+26 IF J
SET @DIALOGO@(N,"PARAM",0)=J
+27 SET @DIALOGO@("E",D0,N)=""
+28 ;
Q2 IF $GET(^DI(.84,D0,6))]""
XECUTE ^(6)
Q1 IF DINAKED=""
QUIT
IF DINAKED["("
IF $ORDER(@(DINAKED))]""
QUIT
QUIT
+1 IF $DATA(@(DINAKED))
+2 QUIT
+3 ;
PARAM SET S=$FIND(K(M),"|",L)
IF 'S
GOTO QP
SET E=$FIND(K(M),"|",S)
IF 'E
GOTO QP
+1 SET X=$EXTRACT(K(M),S,E-2)
IF X=""
GOTO PARAM
+2 SET DIPI(X)=$SELECT($GET(DIPI(X))]"":DIPI(X),1:$GET(DIPI))
SET L=S+$LENGTH(DIPI(X))-$LENGTH(X)
+3 IF ($LENGTH(K(M))+$LENGTH(DIPI(X)))<245
SET K(M)=$EXTRACT(K(M),1,S-2)_DIPI(X)_$EXTRACT(K(M),E,9999)
IF K(M)]""
GOTO PARAM
KILL K(M)
SET M=M-1
GOTO QP
+4 IF $LENGTH($EXTRACT(K(M),1,S-2))+$LENGTH(DIPI(X))<245
SET K(M+1)=$EXTRACT(K(M),E,9999)
SET K(M)=$EXTRACT(K(M),1,S-2)_DIPI(X)
SET M=M+1
SET L=0
GOTO PARAM
+5 IF $LENGTH(DIPI(X))+$LENGTH($EXTRACT(K(M),E,9999))<245
SET K(M+1)=DIPI(X)_$EXTRACT(K(M),E,9999)
SET K(M)=$EXTRACT(K(M),1,S-2)
SET M=M+1
SET L=0
GOTO PARAM
+6 SET K(M+1)=DIPI(X)
SET K(M+2)=$EXTRACT(K(M),E,9999)
SET K(M)=$EXTRACT(K(M),1,S-2)
SET M=M+2
SET L=0
+7 GOTO PARAM
QP QUIT
+1 ;
BTXT NEW M
+1 FOR M=0:0
SET M=$ORDER(K(M))
IF 'M
QUIT
SET J=J+1
Begin DoDot:1
+2 IF DIALOGO'["DIR"
SET @O@(J)=K(M)
QUIT
+3 IF '$ORDER(K(M))
IF '$ORDER(^DI(.84,D0,2,I))
SET @DIALOGO=K(M)
QUIT
+4 SET @DIALOGO@(J)=K(M)
QUIT
End DoDot:1
+5 QUIT
+6 ;
EZBLD(D0,DIPI) ;RETURN SINGLE LINE OF TEXT FROM DIALOG FILE.
+1 ;D0 = DIALOG file IEN, DIPI = Input Params
+2 NEW DINAKED
SET DINAKED=$$LGR^%ZOSV
IF $GET(^DI(.84,+$GET(D0),0))=""
DO Q1
QUIT ""
+3 NEW DILANG
SET DILANG=+$GET(DUZ("LANG"))
+4 NEW X
IF DILANG>1
SET X=$ORDER(^DI(.84,+D0,4,DILANG,1,0))
IF X
SET X=$GET(^(X,0))
+5 IF $GET(X)']""
SET X=$ORDER(^DI(.84,+D0,2,0))
IF X
SET X=$GET(^(X,0))
+6 IF ($PIECE(^DI(.84,+D0,0),"^",3)'["y"!($GET(X)=""))
SET X=$GET(X)
GOTO QEZ
+7 NEW K,S,L,M,I,E
SET M=1
SET L=0
SET K(M)=X
+8 IF $GET(DIPI)]""
IF $ORDER(DIPI(""))=""
SET DIPI(1)=DIPI
+9 DO PARAM
SET X=$GET(K(1))
QEZ Begin DoDot:1
+1 NEW X
DO Q2
QUIT
End DoDot:1
QUIT X
+2 ;
+3 ;
MSG(DIFLGS,DIOUT,DIMARGIN,DICOLUMN,DIINNAME) ;WRITE MESSAGES OR MOVE THEM TO SIMPLE ARRAY.
+1 ;1)Flags, 2)Output array name, 3)Margin width of text, 4)Starting column no., 5)Input array name.
+2 NEW Z,%,X,Y,I,J,K,N,DITYP,DIWIDTH,DITMP,DIIN,DINAKED
SET DINAKED=$$LGR^%ZOSV
+3 IF $GET(DIFLGS)=""
SET DIFLGS="W"
Begin DoDot:1
+4 SET DITMP=0
IF $GET(DIINNAME)=""
SET DIINNAME="^TMP("
SET DITMP=1
QUIT
+5 NEW %
SET %=DIINNAME
IF %'["("
SET DIINNAME=DIINNAME_"("
QUIT
+6 IF $EXTRACT(%,$LENGTH(%))=","
QUIT
+7 IF $EXTRACT(%,$LENGTH(%))=")"
SET DIINNAME=$PIECE(%,")",1)_","
QUIT
+8 SET DIINNAME=%_","
QUIT
End DoDot:1
+9 SET DITYP=""
SET %=0
Begin DoDot:1
+10 FOR Z="E","H","M"
SET %=%+1
IF DIFLGS[Z
IF $DATA(@(DIINNAME_""""_$PIECE("DIERR^DIHELP^DIMSG",U,%)_""""_$PIECE(","_$JOB,U,(DITMP>0))_")"))
SET $PIECE(DITYP,U,%)=$PIECE("DIERR^DIHELP^DIMSG",U,%)
+11 IF DITYP=""
IF $DATA(@(DIINNAME_"""DIERR"""_$PIECE(","_$JOB,U,(DITMP>0))_")"))
SET DITYP="DIERR"
+12 QUIT
End DoDot:1
+13 SET DIWIDTH=$SELECT($GET(DIMARGIN):DIMARGIN,$GET(IOM):(IOM-5),1:75)
SET DICOLUMN=+$GET(DICOLUMN)
+14 IF DIFLGS["A"
KILL DIOUT
SET (K,Z)=0
AWS SET K=K+1
IF K>3
GOTO Q1
+1 IF $PIECE(DITYP,U,K)=""
GOTO AWS
+2 SET DIIN=DIINNAME_""""_$PIECE(DITYP,U,K)_""""
IF DITMP
SET DIIN=DIIN_","_$JOB
+3 SET (I,N)=0
+4 FOR
SET N=$ORDER(@(DIIN_")")@(N))
IF 'N
QUIT
IF K>1
SET X=$GET(@(DIIN_","_N_")"))
IF K>1
Begin DoDot:1
+5 IF DIFLGS["A"
IF '$GET(DIMARGIN)
SET Z=Z+1
SET DIOUT(Z)=X
+6 IF DIFLGS'["W"
IF '$GET(DIMARGIN)
QUIT
+7 SET Y=X
IF X=""
Begin DoDot:2
+8 IF DIFLGS["W"
WRITE !?DICOLUMN,Y
IF DIFLGS["A"&$GET(DIMARGIN)
SET Z=Z+1
SET DIOUT(Z)=Y
+9 QUIT
End DoDot:2
FOR
IF X=""
QUIT
FOR %=$LENGTH(X," "):-1:1
IF %=1&($LENGTH($PIECE(X," ",1,%))>DIWIDTH)
SET X=$EXTRACT(X,1,(DIWIDTH-1))_" "_$EXTRACT(X,DIWIDTH,$LENGTH(X))
SET %=%+1
IF $LENGTH($PIECE(X," ",1,%))'>DIWIDTH
SET Y=$PIECE(X," ",1,%)
Begin DoDot:2
End DoDot:2
SET X=$PIECE(X," ",%+1,$LENGTH(X," "))
QUIT
+10 QUIT
End DoDot:1
IF K=1
IF I&(DIFLGS'["B")
DO LN
SET I=1
SET J=0
FOR
SET J=$ORDER(@(DIIN_")")@(N,"TEXT",J))
IF 'J
QUIT
SET X=$GET(@(DIIN_","_N_",""TEXT"","_J_")"))
Begin DoDot:1
End DoDot:1
+11 FOR I=K:1:2
IF $PIECE(DITYP,U,I+1)]""
DO LN
QUIT
+12 IF DIFLGS["A"
IF DIFLGS["T"
SET DIOUT=Z
+13 IF DIFLGS'["S"
KILL @(DIIN_")"),@($PIECE(DITYP,U,K))
+14 GOTO AWS
+15 ;
LN IF DIFLGS["W"
WRITE !
IF (DIFLGS["A")&Z
SET Z=Z+1
SET DIOUT(Z)=""
QUIT
