DIR ;SFISC/XAK-READER, HELP ;6:35 PM 12 Jul 2013
;;22.0;VA FileMan;**30,163,170**;Mar 30, 1999;Build 12
;Per VHA Directive 2004-038, this routine should not be modified.
N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y,A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1,XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
S:$D(DDH)[0 DDH=0 Q:'$D(DIR(0)) D ^DIR2 G Q:%T=""
I $D(DIR("V"))#2 D ^DIR1 S DDER=%E G Q
A I $D(DDM) K:DDM DDQ S:'DDM DDQ=IOSL-7
I $G(DDH) D LIST^DDSU
D W:%A'["V" I $D(DDS),$D(DIR0) S DDACT=Y I DDO=.5 S DDM=1 G Q
I %A'["V",%E D QUES S A0="" D MSG D:$G(DDH) LIST^DDSU G A
I $D(DTOUT) K Y S DIRUT=1,Y="" G Q
I %T'="E",X?1."^".E K Y S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 S:%T="Y" %=-1 G Q
I %T'="E","@"[X,%A["O" S Y="",DIRUT=1 S:%T="P" Y=-1 G Q
I %A'["O","@"[X,%T'="E" S A0=$C(7)_%A0 D MSG G A
I $D(DDS),$D(DIR0),DIR0N G Q
I $D(%G),$D(DIR("B")),X=DIR("B") S Y=%G G Q
I X'?1."?" K DDQ D ^DIR1 I '%E,$P(DIR(0),U,3)]"" S %X=X D S:'$D(X) %E=1 S X=%X
. N %A,%B,%B1,%B2,%B3,%E,%N,%P,%T,%X,%W,%W0
. X $P(DIR(0),U,3,99)
I %A["V" K:%E Y G Q
I X?1."?"!%E D QUES:%E'<0&'$G(DUOUT)&'$G(DTOUT) S A0="" D MSG D:$G(DDH) LIST^DDSU G A ;**170
G Q
;
W ; write the prompt and read the user's response
S %W=%W0,%N=$E(%W)=U
SCREEN K DTOUT,DUOUT,DIRUT,DIROUT S %E=0 I $D(DDS),$D(DIR0) D ^DIR0 Q ;READ in DIR01 via DIR0
I %T="S",%A'["A",%A'["B" D S
I $D(DIR("A"))=11 F %=0:0 S %=$O(DIR("A",%)) Q:%'>0 W !,DIR("A",%)
W ! W:$L(%P) %P
I $L($G(DIR("B")))>19,%A'["r",%T'="D",%T'="S",(%B'["D"&%T)!'%T,%B'["P"!'$P(%A,",",2) W DIR("B") S Y=DIR("B") D RW^DIR2 S:X="" X=DIR("B") Q
W:$D(DIR("B")) DIR("B")_"// "
R X:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME) I '$T S DTOUT=1
I $D(DIR("PRE")) X DIR("PRE") I '$D(X) S %E=1,X="" Q
I X="",$D(DIR("B")) S X=DIR("B") I %T'="D",%B'["D"&%T W X
I X'?.ANP S X="?"
Q
;
QU I %E!(X="?")!($O(^DD(%B1,%B2,21,0))'>0) K %Y S A0="" D MSG F %C=3,12 I $D(^DD(%B1,%B2,%C)) S X1=^(%C),%J=75,%Y=1 D W1
I $D(^DD(%B1,%B2,4)) S A0=^(4),A0(0)=1 D MSG
I X?1"??".E D
. I $D(DDS) N DDC,DDSQ S DDC=7
. S A0="" D MSG S %C=0
. F S %C=$O(^DD(%B1,%B2,21,%C)) Q:'%C!$D(DDSQ) S A0=^(%C,0) D
.. I $D(DDS),$G(DDH),'(DDH#DDC) D LIST^DDSU Q:$D(DDSQ)
.. D MSG
I %B["P" K DO S DIC=U_$P(%B3,U,3),DIC(0)="M"_$E("L",%B'["'") D AST:%B["*",DQ
I %B["D" S %DT=$P($P($P(%B3,U,5,99),"%DT=""",2),"""",1) D HELP^%DTC
I %B["S" X:$D(^DD(%B1,%B2,12.1)) ^(12.1) S A0=$$EZBLD^DIALOG(8068)_" " D MSG F %C=1:1 S Y=$P($P(%B3,U,3),";",%C) Q:Y="" S %I=$P(Y,":",2),Y=$P(Y,":") I 1 X:$D(DIC("S")) DIC("S") I S A0=Y_$E(" ",$L(Y)+1,999)_%I D MSG
I %B["V" S A0="" D MSG S X1=X,DU=%B1,D=%B2,DZ=X D V^DIEQ S X=X1
Q
DQ N %W S:$D(D)[0 D="B" S (X1,DZ)=X D DQ^DICQ S DDSV=DIC K DD,% S:$D(X1) X=X1
Q
AST F %=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(%B3,%),%=$L(%)+1 Q:Y
Q:'Y
I $D(DDS) S A0=" " D MSG
X $P($E(%B3,1,Y-%),U,5,99)
Q
QUES ;
I %T D QU
I X="??",$D(DIR("??")) D:$P(DIR("??"),U)]"" HF S:$P(DIR("??"),U,2)]"" A0(0)=1,A0=$P(DIR("??"),U,2,99) D:$P(DIR("??"),U,2)]"" MSG Q
I X="??",%T="D" D Q
. N DIHELP,DIJUNK,DILINE,DIROOT
. D DT^DILF(%DT,"?",.DIJUNK,"","DIROOT")
. S A0="" D MSG
. F DILINE=1:1:DIHELP S A0=DIROOT("DIHELP",DILINE) D MSG
I %T="P" S DIC=%B1,DIC(0)=%B2 S:$D(DIR("S"))#2 DIC("S")=DIR("S") D DQ K DIC("S")
I '%N S A0="" D MSG
I X'["?" W $C(7)
I %N S A0(0)=1,A0=$E(%W,2,999) D MSG
D:'%N WRAP:%W]"" I %T["S",(%A["A"!(%A["B")) D S
Q
WRAP I $D(DIR("?"))=11 F %I=1:1 Q:'$D(DIR("?",%I)) S A0=DIR("?",%I) D MSG
K %Y S %J=$S($G(IOM,80)>6:$G(IOM,80)-6,IOM>1:IOM,1:2),%Y=1 S X1=$S(($D(DIR("?"))&'%N):DIR("?"),1:%W)
I '%N,$D(DIR("?"))'=11,$E(X1,$L(X1))'="." S X1=X1_"."
W1 I $L(X1)<%J S %Y(%Y)=X1
E D G W1
. I $E(X1,1,%J-1)'?.E1P.E S %I=%J-1
. E F %I=%J-1:-1:1 Q:$E(X1,%I)?1P
. S %Y(%Y)=$E(X1,1,%I),X1=$E(X1,%I+1,999),%Y=%Y+1
F %I=1:1:%Y S A0=%Y(%I) D MSG
I $D(DDS),%T="S" D
. S A0="Choose from:" D MSG
. F %I=1:1 Q:$P(%B,";",%I,999)="" D
.. S %Y=$P(%B,";",%I),Y=$P(%Y,":") Q:Y=""
.. I $D(DIR("S"))#2 X DIR("S") E Q
.. S A0=Y_$J("",9-$L(Y))_$P(%Y,":",2) D MSG
K %Y,%,X1
Q
HF S XQH=$P(DIR("??"),U) N %A,%B,%E,DIR D EN1^XQH
Q
MSG ;
I $D(DDS),A0]"" D
. S DDH=$G(DDH)+1
. I $D(A0)>9 S DDH(DDH,"T")="",DDH=DDH+1,DDH(DDH,"X")=A0
. E S DDH(DDH,"T")=A0
I '$D(DDS),$D(A0)>9 W:$X ! X A0
I '$D(DDS),$D(A0)=1 W !,A0
K A0
Q
S W:$G(X)'?1."?"!(%A["A") !
I $D(DIR("L"))#2 D
. I $D(DIR("L"))=11 F %=0:0 S %=$O(DIR("L",%)) Q:%'>0 W !,DIR("L",%)
. W !,DIR("L")
E I %B'[":",$O(DIR("C",""))]"" D
. W !?5,"Select one of the following:",!
. S %I="" F S %I=$O(DIR("C",%I)) Q:%I="" D
.. S Y=$P(DIR("C",%I),":")
.. I $D(DIR("S"))#2 X DIR("S") E Q
.. W !?10,Y,?20,$P(DIR("C",%I),":",2)
E D
. W !?5,"Select one of the following:",!
. F %I=1:1 Q:$P(%B,";",%I,999)="" D
.. S Y=$P($P(%B,";",%I),":") Q:'$L($P(%B,";",%I,99))
.. I $D(DIR("S"))#2 X DIR("S") E Q
.. W !?10,Y,?20,$P($P(%B,";",%I),":",2)
W:%A'["A" !
Q
Q G ^DIRQ
;
;#8068 Choose from
DIR ;SFISC/XAK-READER, HELP ;6:35 PM 12 Jul 2013
+1 ;;22.0;VA FileMan;**30,163,170**;Mar 30, 1999;Build 12
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y,A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1,XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M
+4 IF $DATA(DDH)[0
SET DDH=0
IF '$DATA(DIR(0))
QUIT
DO ^DIR2
IF %T=""
GOTO Q
+5 IF $DATA(DIR("V"))#2
DO ^DIR1
SET DDER=%E
GOTO Q
A IF $DATA(DDM)
IF DDM
KILL DDQ
IF 'DDM
SET DDQ=IOSL-7
+1 IF $GET(DDH)
DO LIST^DDSU
+2 IF %A'["V"
DO W
IF $DATA(DDS)
IF $DATA(DIR0)
SET DDACT=Y
IF DDO=.5
SET DDM=1
GOTO Q
+3 IF %A'["V"
IF %E
DO QUES
SET A0=""
DO MSG
IF $GET(DDH)
DO LIST^DDSU
GOTO A
+4 IF $DATA(DTOUT)
KILL Y
SET DIRUT=1
SET Y=""
GOTO Q
+5 IF %T'="E"
IF X?1."^".E
KILL Y
SET (DUOUT,DIRUT)=1
SET Y=X
IF X="^^"
SET DIROUT=1
IF %T="Y"
SET %=-1
GOTO Q
+6 IF %T'="E"
IF "@"[X
IF %A["O"
SET Y=""
SET DIRUT=1
IF %T="P"
SET Y=-1
GOTO Q
+7 IF %A'["O"
IF "@"[X
IF %T'="E"
SET A0=$CHAR(7)_%A0
DO MSG
GOTO A
+8 IF $DATA(DDS)
IF $DATA(DIR0)
IF DIR0N
GOTO Q
+9 IF $DATA(%G)
IF $DATA(DIR("B"))
IF X=DIR("B")
SET Y=%G
GOTO Q
+10 IF X'?1."?"
KILL DDQ
DO ^DIR1
IF '%E
IF $PIECE(DIR(0),U,3)]""
SET %X=X
Begin DoDot:1
+11 NEW %A,%B,%B1,%B2,%B3,%E,%N,%P,%T,%X,%W,%W0
+12 XECUTE $PIECE(DIR(0),U,3,99)
End DoDot:1
IF '$DATA(X)
SET %E=1
SET X=%X
+13 IF %A["V"
IF %E
KILL Y
GOTO Q
+14 ;**170
IF X?1."?"!%E
IF %E'<0&'$GET(DUOUT)&'$GET(DTOUT)
DO QUES
SET A0=""
DO MSG
IF $GET(DDH)
DO LIST^DDSU
GOTO A
+15 GOTO Q
+16 ;
W ; write the prompt and read the user's response
+1 SET %W=%W0
SET %N=$EXTRACT(%W)=U
SCREEN ;READ in DIR01 via DIR0
KILL DTOUT,DUOUT,DIRUT,DIROUT
SET %E=0
IF $DATA(DDS)
IF $DATA(DIR0)
DO ^DIR0
QUIT
+1 IF %T="S"
IF %A'["A"
IF %A'["B"
DO S
+2 IF $DATA(DIR("A"))=11
FOR %=0:0
SET %=$ORDER(DIR("A",%))
IF %'>0
QUIT
WRITE !,DIR("A",%)
+3 WRITE !
IF $LENGTH(%P)
WRITE %P
+4 IF $LENGTH($GET(DIR("B")))>19
IF %A'["r"
IF %T'="D"
IF %T'="S"
IF (%B'["D"&%T)!'%T
IF %B'["P"!'$PIECE(%A,",",2)
WRITE DIR("B")
SET Y=DIR("B")
DO RW^DIR2
IF X=""
SET X=DIR("B")
QUIT
+5 IF $DATA(DIR("B"))
WRITE DIR("B")_"// "
+6 READ X:$SELECT($DATA(DIR("T")):DIR("T"),'$DATA(DTIME):300,1:DTIME)
IF '$TEST
SET DTOUT=1
+7 IF $DATA(DIR("PRE"))
XECUTE DIR("PRE")
IF '$DATA(X)
SET %E=1
SET X=""
QUIT
+8 IF X=""
IF $DATA(DIR("B"))
SET X=DIR("B")
IF %T'="D"
IF %B'["D"&%T
WRITE X
+9 IF X'?.ANP
SET X="?"
+10 QUIT
+11 ;
QU IF %E!(X="?")!($ORDER(^DD(%B1,%B2,21,0))'>0)
KILL %Y
SET A0=""
DO MSG
FOR %C=3,12
IF $DATA(^DD(%B1,%B2,%C))
SET X1=^(%C)
SET %J=75
SET %Y=1
DO W1
+1 IF $DATA(^DD(%B1,%B2,4))
SET A0=^(4)
SET A0(0)=1
DO MSG
+2 IF X?1"??".E
Begin DoDot:1
+3 IF $DATA(DDS)
NEW DDC,DDSQ
SET DDC=7
+4 SET A0=""
DO MSG
SET %C=0
+5 FOR
SET %C=$ORDER(^DD(%B1,%B2,21,%C))
IF '%C!$DATA(DDSQ)
QUIT
SET A0=^(%C,0)
Begin DoDot:2
+6 IF $DATA(DDS)
IF $GET(DDH)
IF '(DDH#DDC)
DO LIST^DDSU
IF $DATA(DDSQ)
QUIT
+7 DO MSG
End DoDot:2
End DoDot:1
+8 IF %B["P"
KILL DO
SET DIC=U_$PIECE(%B3,U,3)
SET DIC(0)="M"_$EXTRACT("L",%B'["'")
IF %B["*"
DO AST
DO DQ
+9 IF %B["D"
SET %DT=$PIECE($PIECE($PIECE(%B3,U,5,99),"%DT=""",2),"""",1)
DO HELP^%DTC
+10 IF %B["S"
IF $DATA(^DD(%B1,%B2,12.1))
XECUTE ^(12.1)
SET A0=$$EZBLD^DIALOG(8068)_" "
DO MSG
FOR %C=1:1
SET Y=$PIECE($PIECE(%B3,U,3),";",%C)
IF Y=""
QUIT
SET %I=$PIECE(Y,":",2)
SET Y=$PIECE(Y,":")
IF 1
IF $DATA(DIC("S"))
XECUTE DIC("S")
IF $TEST
SET A0=Y_$EXTRACT(" ",$LENGTH(Y)+1,999)_%I
DO MSG
+11 IF %B["V"
SET A0=""
DO MSG
SET X1=X
SET DU=%B1
SET D=%B2
SET DZ=X
DO V^DIEQ
SET X=X1
+12 QUIT
DQ NEW %W
IF $DATA(D)[0
SET D="B"
SET (X1,DZ)=X
DO DQ^DICQ
SET DDSV=DIC
KILL DD,%
IF $DATA(X1)
SET X=X1
+1 QUIT
AST FOR %=" D ^DIC"," D IX^DIC"," D MIX^DIC1"
SET Y=$FIND(%B3,%)
SET %=$LENGTH(%)+1
IF Y
QUIT
+1 IF 'Y
QUIT
+2 IF $DATA(DDS)
SET A0=" "
DO MSG
+3 XECUTE $PIECE($EXTRACT(%B3,1,Y-%),U,5,99)
+4 QUIT
QUES ;
+1 IF %T
DO QU
+2 IF X="??"
IF $DATA(DIR("??"))
IF $PIECE(DIR("??"),U)]""
DO HF
IF $PIECE(DIR("??"),U,2)]""
SET A0(0)=1
SET A0=$PIECE(DIR("??"),U,2,99)
IF $PIECE(DIR("??"),U,2)]""
DO MSG
QUIT
+3 IF X="??"
IF %T="D"
Begin DoDot:1
+4 NEW DIHELP,DIJUNK,DILINE,DIROOT
+5 DO DT^DILF(%DT,"?",.DIJUNK,"","DIROOT")
+6 SET A0=""
DO MSG
+7 FOR DILINE=1:1:DIHELP
SET A0=DIROOT("DIHELP",DILINE)
DO MSG
End DoDot:1
QUIT
+8 IF %T="P"
SET DIC=%B1
SET DIC(0)=%B2
IF $DATA(DIR("S"))#2
SET DIC("S")=DIR("S")
DO DQ
KILL DIC("S")
+9 IF '%N
SET A0=""
DO MSG
+10 IF X'["?"
WRITE $CHAR(7)
+11 IF %N
SET A0(0)=1
SET A0=$EXTRACT(%W,2,999)
DO MSG
+12 IF '%N
IF %W]""
DO WRAP
IF %T["S"
IF (%A["A"!(%A["B"))
DO S
+13 QUIT
WRAP IF $DATA(DIR("?"))=11
FOR %I=1:1
IF '$DATA(DIR("?",%I))
QUIT
SET A0=DIR("?",%I)
DO MSG
+1 KILL %Y
SET %J=$SELECT($GET(IOM,80)>6:$GET(IOM,80)-6,IOM>1:IOM,1:2)
SET %Y=1
SET X1=$SELECT(($DATA(DIR("?"))&'%N):DIR("?"),1:%W)
+2 IF '%N
IF $DATA(DIR("?"))'=11
IF $EXTRACT(X1,$LENGTH(X1))'="."
SET X1=X1_"."
W1 IF $LENGTH(X1)<%J
SET %Y(%Y)=X1
+1 IF '$TEST
Begin DoDot:1
+2 IF $EXTRACT(X1,1,%J-1)'?.E1P.E
SET %I=%J-1
+3 IF '$TEST
FOR %I=%J-1:-1:1
IF $EXTRACT(X1,%I)?1P
QUIT
+4 SET %Y(%Y)=$EXTRACT(X1,1,%I)
SET X1=$EXTRACT(X1,%I+1,999)
SET %Y=%Y+1
End DoDot:1
GOTO W1
+5 FOR %I=1:1:%Y
SET A0=%Y(%I)
DO MSG
+6 IF $DATA(DDS)
IF %T="S"
Begin DoDot:1
+7 SET A0="Choose from:"
DO MSG
+8 FOR %I=1:1
IF $PIECE(%B,";",%I,999)=""
QUIT
Begin DoDot:2
+9 SET %Y=$PIECE(%B,";",%I)
SET Y=$PIECE(%Y,":")
IF Y=""
QUIT
+10 IF $DATA(DIR("S"))#2
XECUTE DIR("S")
IF '$TEST
QUIT
+11 SET A0=Y_$JUSTIFY("",9-$LENGTH(Y))_$PIECE(%Y,":",2)
DO MSG
End DoDot:2
End DoDot:1
+12 KILL %Y,%,X1
+13 QUIT
HF SET XQH=$PIECE(DIR("??"),U)
NEW %A,%B,%E,DIR
DO EN1^XQH
+1 QUIT
MSG ;
+1 IF $DATA(DDS)
IF A0]""
Begin DoDot:1
+2 SET DDH=$GET(DDH)+1
+3 IF $DATA(A0)>9
SET DDH(DDH,"T")=""
SET DDH=DDH+1
SET DDH(DDH,"X")=A0
+4 IF '$TEST
SET DDH(DDH,"T")=A0
End DoDot:1
+5 IF '$DATA(DDS)
IF $DATA(A0)>9
IF $X
WRITE !
XECUTE A0
+6 IF '$DATA(DDS)
IF $DATA(A0)=1
WRITE !,A0
+7 KILL A0
+8 QUIT
S IF $GET(X)'?1."?"!(%A["A")
WRITE !
+1 IF $DATA(DIR("L"))#2
Begin DoDot:1
+2 IF $DATA(DIR("L"))=11
FOR %=0:0
SET %=$ORDER(DIR("L",%))
IF %'>0
QUIT
WRITE !,DIR("L",%)
+3 WRITE !,DIR("L")
End DoDot:1
+4 IF '$TEST
IF %B'[":"
IF $ORDER(DIR("C",""))]""
Begin DoDot:1
+5 WRITE !?5,"Select one of the following:",!
+6 SET %I=""
FOR
SET %I=$ORDER(DIR("C",%I))
IF %I=""
QUIT
Begin DoDot:2
+7 SET Y=$PIECE(DIR("C",%I),":")
+8 IF $DATA(DIR("S"))#2
XECUTE DIR("S")
IF '$TEST
QUIT
+9 WRITE !?10,Y,?20,$PIECE(DIR("C",%I),":",2)
End DoDot:2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 WRITE !?5,"Select one of the following:",!
+12 FOR %I=1:1
IF $PIECE(%B,";",%I,999)=""
QUIT
Begin DoDot:2
+13 SET Y=$PIECE($PIECE(%B,";",%I),":")
IF '$LENGTH($PIECE(%B,";",%I,99))
QUIT
+14 IF $DATA(DIR("S"))#2
XECUTE DIR("S")
IF '$TEST
QUIT
+15 WRITE !?10,Y,?20,$PIECE($PIECE(%B,";",%I),":",2)
End DoDot:2
End DoDot:1
+16 IF %A'["A"
WRITE !
+17 QUIT
Q GOTO ^DIRQ
+1 ;
+2 ;#8068 Choose from
