- 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
