- DICATT22 ;SFISC/GFT-CREATE A SUBFILE ;7:38 AM 3 Jan 2002 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**52,89**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- G M:V I P,$D(^DD(J(N-1),P,0)) S I=A_$E("I",$P(^(0),U,2)["I") D P
- I O,DA=.01,'N S I=$P(@(I(0)_"0)"),U,2) D P
- 1 ;
- S %=$L(F)+$L(W)+$L(C)+$L(Z) I %>242 W $C(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!" G TYPE^DICATT2
- I T["P",$D(O)=11,+$P($P(O(1),U,2),"P",2)'=+$P(Z,"P",2) S X=$P(O(1),U,2),DA(1)=A X:$D(^DD(0,.2,1,3,2)) ^(2)
- S ^DD(A,DA,0)=F_U_Z_U_W_U_C S:$P(Z,U)["K" ^(9)="@" D SDIK,I G N^DICATT
- ;
- Q W $C(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE"
- M S %=$P(A,"."),DE=%_"."_+$P(A,".",2)_DA I +DE'=DE!$D(^DD(DE)) F DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001 Q:DE>A&'$D(^DD(DE))
- I DUZ(0)="@" W !,"SUB-DICTIONARY NUMBER: "_DE_"// " R DG:DTIME S:'$T DTOUT=1 G:DG=U!'$T ^DICATT2 S:DG]"" DE=DG G Q:+DE'=DE!(DE<A)
- G Q:%+1'>DE!$D(^DD(DE)) S I=DE,^(I,0)=F_" SUB-FIELD^^.01^1",^(0,"UP")=A,^("NM",F)="",%X="^DD("_A_","_DA_")",@%X@(0)=F_"^^^"_W D P
- S W=$P(W,";") D SDIK S:+W'=W W=""""_W_""""
- S (N,DICL)=N+1,I(N)=W,J(N)=DE,DA=.01,^DD(DE,DA,0)=F_U_Z_"^0;1^"_C,%Y="^DD("_DE_",.01)"
- VARPOINT I T["V" D
- . N I,FI,FD,P
- . S FI=$QS(%X,1),FD=$QS(%X,2)
- . S I=0
- . F S I=$O(@%X@("V",I)) Q:'I S P=+$G(^(I,0)) K:P ^DD(P,0,"PT",FI,FD)
- . M @%Y@("V")=@%X@("V") K @%X@("V")
- POINT I T["P" F %=12,12.1 I $D(@%X@(%)) S @%Y@(%)=@%X@(%) K @%X@(%)
- K %X,%Y
- I T'["W" D
- .S ^DD(DE,DA,1,0)="^.1",^(1,0)=DE_"^B",DIK=W_",""B"",$E(X,1,30),DA)"
- .F %=DICL-1:-1 S DIK=I(%)_$E(",",1,%)_"DA("_(DICL-%)_"),"_DIK I '% S ^(1)="S "_DIK_"=""""",^(2)="K "_DIK S:T["V" ^(3)="Required Index for Variable Pointer" Q
- D SDIK,I S DICL=DICL-1 G N^DICATT
- ;
- I I $P(O,U,2,99)'=$P(^DD(J(N),DA,0),U,2,99) S:$D(M)#2 ^(3)=M S M(1)=0,^("DT")=DT,^DD(J(N),0,"DT")=DT F DR=J(N):0 Q:'$D(^DD(DR,0,"UP")) S DR=^("UP"),^DD(DR,0,"DT")=DT
- K DR,DG,DB,DQ,DQI,^DD(U,$J),^UTILITY("DIVR",$J)
- S DIE=DIK,DR=$S(DUZ(0)="@":"3;4",1:3)_$P(";21",U,'O) D DIE I T="W" K DE
- I $D(M)>9,O S V=DICL,DR=$P(Z,U),Z=$P(Z,U,2) D ;It's not clear that we need these variables set, now we are calling DIVR^DIUTL 12/01
- V .S DI=J(N) D DIPZ^DIU0 Q:$D(DTOUT)!'$D(DIZ)
- .D DIVR^DIUTL(A,D0)
- K DR,M Q
- ;
- DIE ;
- N I,J
- D ^DIE
- Q
- ;
- P F Y="S","D","P","A","V" S:I[Y I=$P(I,Y)_$P(I,Y,2)_$P(I,Y,3) S:T[Y I=I_Y
- S ^(0)=$P(^(0),U)_U_I_U_$P(^(0),U,3,99) Q
- ;
- SDIK N %X
- S DA(1)=J(DICL),DIK="^DD("_DA(1)_"," I O K ^DD(DA(1),"RQ",DA)
- W !,"...." G IX1^DIK
- DICATT22 ;SFISC/GFT-CREATE A SUBFILE ;7:38 AM 3 Jan 2002 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**52,89**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 IF V
- GOTO M
- IF P
- IF $DATA(^DD(J(N-1),P,0))
- SET I=A_$EXTRACT("I",$PIECE(^(0),U,2)["I")
- DO P
- +5 IF O
- IF DA=.01
- IF 'N
- SET I=$PIECE(@(I(0)_"0)"),U,2)
- DO P
- 1 ;
- +1 SET %=$LENGTH(F)+$LENGTH(W)+$LENGTH(C)+$LENGTH(Z)
- IF %>242
- WRITE $CHAR(7),!?5,"Field Definition is TOO LONG by ",%-242," characters!"
- GOTO TYPE^DICATT2
- +2 IF T["P"
- IF $DATA(O)=11
- IF +$PIECE($PIECE(O(1),U,2),"P",2)'=+$PIECE(Z,"P",2)
- SET X=$PIECE(O(1),U,2)
- SET DA(1)=A
- IF $DATA(^DD(0,.2,1,3,2))
- XECUTE ^(2)
- +3 SET ^DD(A,DA,0)=F_U_Z_U_W_U_C
- IF $PIECE(Z,U)["K"
- SET ^(9)="@"
- DO SDIK
- DO I
- GOTO N^DICATT
- +4 ;
- Q WRITE $CHAR(7),!,"NUMBER MUST BE BETWEEN ",A," & ",%+1," AND NOT ALREADY IN USE"
- M SET %=$PIECE(A,".")
- SET DE=%_"."_+$PIECE(A,".",2)_DA
- IF +DE'=DE!$DATA(^DD(DE))
- FOR DE=A+.01:.01:%+.7,%+.7:.001:%+.9,%+.9:.0001
- IF DE>A&'$DATA(^DD(DE))
- QUIT
- +1 IF DUZ(0)="@"
- WRITE !,"SUB-DICTIONARY NUMBER: "_DE_"// "
- READ DG:DTIME
- IF '$TEST
- SET DTOUT=1
- IF DG=U!'$TEST
- GOTO ^DICATT2
- IF DG]""
- SET DE=DG
- IF +DE'=DE!(DE<A)
- GOTO Q
- +2 IF %+1'>DE!$DATA(^DD(DE))
- GOTO Q
- SET I=DE
- SET ^(I,0)=F_" SUB-FIELD^^.01^1"
- SET ^(0,"UP")=A
- SET ^("NM",F)=""
- SET %X="^DD("_A_","_DA_")"
- SET @%X@(0)=F_"^^^"_W
- DO P
- +3 SET W=$PIECE(W,";")
- DO SDIK
- IF +W'=W
- SET W=""""_W_""""
- +4 SET (N,DICL)=N+1
- SET I(N)=W
- SET J(N)=DE
- SET DA=.01
- SET ^DD(DE,DA,0)=F_U_Z_"^0;1^"_C
- SET %Y="^DD("_DE_",.01)"
- VARPOINT IF T["V"
- Begin DoDot:1
- +1 NEW I,FI,FD,P
- +2 SET FI=$QSUBSCRIPT(%X,1)
- SET FD=$QSUBSCRIPT(%X,2)
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(@%X@("V",I))
- IF 'I
- QUIT
- SET P=+$GET(^(I,0))
- IF P
- KILL ^DD(P,0,"PT",FI,FD)
- +5 MERGE @%Y@("V")=@%X@("V")
- KILL @%X@("V")
- End DoDot:1
- POINT IF T["P"
- FOR %=12,12.1
- IF $DATA(@%X@(%))
- SET @%Y@(%)=@%X@(%)
- KILL @%X@(%)
- +1 KILL %X,%Y
- +2 IF T'["W"
- Begin DoDot:1
- +3 SET ^DD(DE,DA,1,0)="^.1"
- SET ^(1,0)=DE_"^B"
- SET DIK=W_",""B"",$E(X,1,30),DA)"
- +4 FOR %=DICL-1:-1
- SET DIK=I(%)_$EXTRACT(",",1,%)_"DA("_(DICL-%)_"),"_DIK
- IF '%
- SET ^(1)="S "_DIK_"="""""
- SET ^(2)="K "_DIK
- IF T["V"
- SET ^(3)="Required Index for Variable Pointer"
- QUIT
- End DoDot:1
- +5 DO SDIK
- DO I
- SET DICL=DICL-1
- GOTO N^DICATT
- +6 ;
- I IF $PIECE(O,U,2,99)'=$PIECE(^DD(J(N),DA,0),U,2,99)
- IF $DATA(M)#2
- SET ^(3)=M
- SET M(1)=0
- SET ^("DT")=DT
- SET ^DD(J(N),0,"DT")=DT
- FOR DR=J(N):0
- IF '$DATA(^DD(DR,0,"UP"))
- QUIT
- SET DR=^("UP")
- SET ^DD(DR,0,"DT")=DT
- +1 KILL DR,DG,DB,DQ,DQI,^DD(U,$JOB),^UTILITY("DIVR",$JOB)
- +2 SET DIE=DIK
- SET DR=$SELECT(DUZ(0)="@":"3;4",1:3)_$PIECE(";21",U,'O)
- DO DIE
- IF T="W"
- KILL DE
- +3 ;It's not clear that we need these variables set, now we are calling DIVR^DIUTL 12/01
- IF $DATA(M)>9
- IF O
- SET V=DICL
- SET DR=$PIECE(Z,U)
- SET Z=$PIECE(Z,U,2)
- Begin DoDot:1
- V SET DI=J(N)
- DO DIPZ^DIU0
- IF $DATA(DTOUT)!'$DATA(DIZ)
- QUIT
- +1 DO DIVR^DIUTL(A,D0)
- End DoDot:1
- +2 KILL DR,M
- QUIT
- +3 ;
- DIE ;
- +1 NEW I,J
- +2 DO ^DIE
- +3 QUIT
- +4 ;
- P FOR Y="S","D","P","A","V"
- IF I[Y
- SET I=$PIECE(I,Y)_$PIECE(I,Y,2)_$PIECE(I,Y,3)
- IF T[Y
- SET I=I_Y
- +1 SET ^(0)=$PIECE(^(0),U)_U_I_U_$PIECE(^(0),U,3,99)
- QUIT
- +2 ;
- SDIK NEW %X
- +1 SET DA(1)=J(DICL)
- SET DIK="^DD("_DA(1)_","
- IF O
- KILL ^DD(DA(1),"RQ",DA)
- +2 WRITE !,"...."
- GOTO IX1^DIK
