DIDX ;SFISC/XAK-BRIEF DD ;06:18 PM 20 Mar 2001 [ 12/09/2003 4:31 PM ]
;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S D1=D0,DINM=1,DDRG=1,DDL1=14,DDL2=32 G B
;
L S DJ(Z)=0
A I DIDX D G:D1>0 A:^DD(F(Z),"B",DJ(Z),D1)
. S DJ(Z)=$O(^DD(F(Z),"B",DJ(Z))) S:DJ(Z)="" D1="" Q:DJ(Z)="" S D1=$O(^(DJ(Z),0))
. Q
E S (D1,DJ(Z))=$O(^DD(F(Z),DJ(Z)))
I D1'>0 W ! S Z=Z-1 Q
B I $D(DIGR),D1-.01!'DID X DIGR E G END
S N=^DD(F(Z),D1,0) D HD:$Y+9>IOSL Q:M=U W !!?Z+Z-2,$P(N,U,1),?30,S,F(Z),",",D1,S,S
S X=$P(N,U,2) I X W ?M,$J(+X,8) I $D(^DD(+X,.01,0)),$P(^(0),U,2)["W" W " WORD-PROCESSING" S X=""
W ?M,S,S F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K","p" I X[$E(W) S:W="K" W="MUMPS" S:W="p" W="POINTER" D W1 I X["V" D VP0
G T:X'["P"!X S Y=$P(N,U,3) I Y]"",@("$D(^"_Y_"0))") S W="TO "_$P(^(0),U,1)_" FILE (#"_+$P(X,"P",2)_")" D W1 G T
S W="***** TO A FILE THAT IS UNDEFINED *******" D W1
T ;
S W=0
H ;
W ! I $D(^DD(F(Z),D1,.1))#2 W ?(Z*2),^(.1)," ",?M
I X["S" S N=$P(N,U,3) F I=1:1 S Y=$P(N,";",I) Q:Y="" S W="'"_$P(Y,":")_"' FOR "_$P(Y,":",2)_";" W ?M," "_W,!
I $D(^DD(F(Z),D1,3))#2 S W=^(3) W ?M D W1
RD ;
I X S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X,W=" Multiple" D W1,L
END S X="" G:M'=U A:Z>1 Q
;
W1 W:$X+$L(W)+3>IOM !,?$S(IOM-$L(W)-5<M:IOM-5-$L(W),1:M),S S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1),S I %Y]"" S W=%Y G W1
D:$Y>IOSL HD Q
;
HD S DC=DC+1 D ^DIDH
Q
VP ;Variable Pointer
W ?50,W S D1=DJ(Z)
VP0 I '$D(^DD(F(Z),D1,"V",0)) S W="" Q
S DID1=0,DIMU=0,DID2=0 I '$D(DDRG) D RT
S W="FILE ORDER PREFIX LAYGO MESSAGE" W !?(Z+Z+12),W G Q:M=U
VP1 S DID2=$O(^DD(F(Z),D1,"V",DID2)) S:DID2="" DID2=-1 G:DID2'>0 VP2 S DIDV=^(DID2,0) I '$D(^DIC(+DIDV,0)) S DIDV(+DIDV)=""
S DIVP=$P(DIDV,U),DDLF=(Z+Z+15) I $L(DIVP)>4 W !?(DDLF-$L(DIVP))+1,DIVP
E W !?DDLF,DIVP
W ?(DDLF+5),$P(DIDV,U,3),?(DDLF+10),$P(DIDV,U,4),?(DDLF+23),$P(DIDV,U,6) S DDL3=DDL2,DDL2=DDLF+27,W=$P(DIDV,U,2) D W1^DIDH1 S DDL2=DDL3 S:$P(DIDV,U,5)["y" DIMU=1 D:$Y+4>IOSL HD G ND^DID1:M=U,VP1
VP2 I DIMU S DIDVI=0 F S DIDVI=$O(^DD(F(Z),D1,"V",DIDVI)) Q:DIDVI'>0 I $D(^(DIDVI,1)) S %=^(0) D VP3 Q:M=U
S DIDV=0 F S DIDV=$O(DIDV(DIDV)) Q:DIDV'>0 S W="!! FILE "_DIDV_" DOES NOT EXIST !!" D W^DID1 Q:M=U
Q W ! K DID2,DIMU,DID1,DIDV,DIDVI S W="" Q
VP3 ;
W !?(Z+Z+12),"SCREEN"_$S('$D(DINM):" ON FILE "_$P(%,U)_":",1:" EXPLANATION ON FILE "_$P(%,U)_":") S W=" "_$S('$D(DINM):^(1),1:$S($D(^(2)):^(2),1:"")) D W^DID1:'$D(DINM),W^DIDH:$D(DINM)
Q
RT F W="Required","Add New Entry without Asking","Multiply asked","audited" I X[$E(W,1) S W=" ("_W_")" W:($L(W)+$X)'<IOM ! D W^DID1 G ND^DID1:M=U
I $D(^DD("KEY","F",F(Z),DJ(Z))) S W=" (Key field)" W:($L(W)+$X)'<IOM ! D W^DID1 G ND^DID1:M=U
W ! I $D(^DD(F(Z),DJ(Z),.1)),^(.1)]"" W !?(Z+Z+12),^(.1)," ",?M
Q
AH W !,"ALPHABETICALLY BY LABEL" D YN^DICN Q:%<0 S:%=1 DIDX=1,BY="@.01"
I '% W !?5,"Enter YES to list the fields ALPHABETICALLY BY LABEL.",!?5,"Enter NO to list the fields by NUMBER." S %=2 G AH
Q
DIDX ;SFISC/XAK-BRIEF DD ;06:18 PM 20 Mar 2001 [ 12/09/2003 4:31 PM ]
+1 ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET D1=D0
SET DINM=1
SET DDRG=1
SET DDL1=14
SET DDL2=32
GOTO B
+4 ;
L SET DJ(Z)=0
A IF DIDX
Begin DoDot:1
+1 SET DJ(Z)=$ORDER(^DD(F(Z),"B",DJ(Z)))
IF DJ(Z)=""
SET D1=""
IF DJ(Z)=""
QUIT
SET D1=$ORDER(^(DJ(Z),0))
+2 QUIT
End DoDot:1
IF D1>0
IF ^DD(F(Z),"B",DJ(Z),D1)
GOTO A
+3 IF '$TEST
SET (D1,DJ(Z))=$ORDER(^DD(F(Z),DJ(Z)))
+4 IF D1'>0
WRITE !
SET Z=Z-1
QUIT
B IF $DATA(DIGR)
IF D1-.01!'DID
XECUTE DIGR
IF '$TEST
GOTO END
+1 SET N=^DD(F(Z),D1,0)
IF $Y+9>IOSL
DO HD
IF M=U
QUIT
WRITE !!?Z+Z-2,$PIECE(N,U,1),?30,S,F(Z),",",D1,S,S
+2 SET X=$PIECE(N,U,2)
IF X
WRITE ?M,$JUSTIFY(+X,8)
IF $DATA(^DD(+X,.01,0))
IF $PIECE(^(0),U,2)["W"
WRITE " WORD-PROCESSING"
SET X=""
+3 WRITE ?M,S,S
FOR W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","VARIABLE POINTER","K","p"
IF X[$EXTRACT(W)
IF W="K"
SET W="MUMPS"
IF W="p"
SET W="POINTER"
DO W1
IF X["V"
DO VP0
+4 IF X'["P"!X
GOTO T
SET Y=$PIECE(N,U,3)
IF Y]""
IF @("$D(^"_Y_"0))")
SET W="TO "_$PIECE(^(0),U,1)_" FILE (#"_+$PIECE(X,"P",2)_")"
DO W1
GOTO T
+5 SET W="***** TO A FILE THAT IS UNDEFINED *******"
DO W1
T ;
+1 SET W=0
H ;
+1 WRITE !
IF $DATA(^DD(F(Z),D1,.1))#2
WRITE ?(Z*2),^(.1)," ",?M
+2 IF X["S"
SET N=$PIECE(N,U,3)
FOR I=1:1
SET Y=$PIECE(N,";",I)
IF Y=""
QUIT
SET W="'"_$PIECE(Y,":")_"' FOR "_$PIECE(Y,":",2)_";"
WRITE ?M," "_W,!
+3 IF $DATA(^DD(F(Z),D1,3))#2
SET W=^(3)
WRITE ?M
DO W1
RD ;
+1 IF X
SET Z=Z+1
SET DDL1=DDL1+2
SET DDL2=DDL2+2
SET F(Z)=+X
SET W=" Multiple"
DO W1
DO L
END SET X=""
IF M'=U
IF Z>1
GOTO A
QUIT
+1 ;
W1 IF $X+$LENGTH(W)+3>IOM
WRITE !,?$SELECT(IOM-$LENGTH(W)-5<M:IOM-5-$LENGTH(W),1:M),S
SET %Y=$EXTRACT(W,IOM-$X,999)
WRITE $EXTRACT(W,1,IOM-$X-1),S
IF %Y]""
SET W=%Y
GOTO W1
+1 IF $Y>IOSL
DO HD
QUIT
+2 ;
HD SET DC=DC+1
DO ^DIDH
+1 QUIT
VP ;Variable Pointer
+1 WRITE ?50,W
SET D1=DJ(Z)
VP0 IF '$DATA(^DD(F(Z),D1,"V",0))
SET W=""
QUIT
+1 SET DID1=0
SET DIMU=0
SET DID2=0
IF '$DATA(DDRG)
DO RT
+2 SET W="FILE ORDER PREFIX LAYGO MESSAGE"
WRITE !?(Z+Z+12),W
IF M=U
GOTO Q
VP1 SET DID2=$ORDER(^DD(F(Z),D1,"V",DID2))
IF DID2=""
SET DID2=-1
IF DID2'>0
GOTO VP2
SET DIDV=^(DID2,0)
IF '$DATA(^DIC(+DIDV,0))
SET DIDV(+DIDV)=""
+1 SET DIVP=$PIECE(DIDV,U)
SET DDLF=(Z+Z+15)
IF $LENGTH(DIVP)>4
WRITE !?(DDLF-$LENGTH(DIVP))+1,DIVP
+2 IF '$TEST
WRITE !?DDLF,DIVP
+3 WRITE ?(DDLF+5),$PIECE(DIDV,U,3),?(DDLF+10),$PIECE(DIDV,U,4),?(DDLF+23),$PIECE(DIDV,U,6)
SET DDL3=DDL2
SET DDL2=DDLF+27
SET W=$PIECE(DIDV,U,2)
DO W1^DIDH1
SET DDL2=DDL3
IF $PIECE(DIDV,U,5)["y"
SET DIMU=1
IF $Y+4>IOSL
DO HD
IF M=U
GOTO ND^DID1
GOTO VP1
VP2 IF DIMU
SET DIDVI=0
FOR
SET DIDVI=$ORDER(^DD(F(Z),D1,"V",DIDVI))
IF DIDVI'>0
QUIT
IF $DATA(^(DIDVI,1))
SET %=^(0)
DO VP3
IF M=U
QUIT
+1 SET DIDV=0
FOR
SET DIDV=$ORDER(DIDV(DIDV))
IF DIDV'>0
QUIT
SET W="!! FILE "_DIDV_" DOES NOT EXIST !!"
DO W^DID1
IF M=U
QUIT
Q WRITE !
KILL DID2,DIMU,DID1,DIDV,DIDVI
SET W=""
QUIT
VP3 ;
+1 WRITE !?(Z+Z+12),"SCREEN"_$SELECT('$DATA(DINM):" ON FILE "_$PIECE(%,U)_":",1:" EXPLANATION ON FILE "_$PIECE(%,U)_":")
SET W=" "_$SELECT('$DATA(DINM):^(1),1:$SELECT($DATA(^(2)):^(2),1:""))
IF '$DATA(DINM)
DO W^DID1
IF $DATA(DINM)
DO W^DIDH
+2 QUIT
RT FOR W="Required","Add New Entry without Asking","Multiply asked","audited"
IF X[$EXTRACT(W,1)
SET W=" ("_W_")"
IF ($LENGTH(W)+$X)'<IOM
WRITE !
DO W^DID1
IF M=U
GOTO ND^DID1
+1 IF $DATA(^DD("KEY","F",F(Z),DJ(Z)))
SET W=" (Key field)"
IF ($LENGTH(W)+$X)'<IOM
WRITE !
DO W^DID1
IF M=U
GOTO ND^DID1
+2 WRITE !
IF $DATA(^DD(F(Z),DJ(Z),.1))
IF ^(.1)]""
WRITE !?(Z+Z+12),^(.1)," ",?M
+3 QUIT
AH WRITE !,"ALPHABETICALLY BY LABEL"
DO YN^DICN
IF %<0
QUIT
IF %=1
SET DIDX=1
SET BY="@.01"
+1 IF '%
WRITE !?5,"Enter YES to list the fields ALPHABETICALLY BY LABEL.",!?5,"Enter NO to list the fields by NUMBER."
SET %=2
GOTO AH
+2 QUIT
