DICATTDE ;GFT;;END SCREEN EDIT ; 04 Jun 2007 3:39 PM
;;22.0;VA FileMan;**42,83,103,151**;Mar 30, 1999;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
;
LAYGODEF ;should user see 'ADDING NEW'?
N %
I DICATTF=.01,$G(^DD(DICATTA,0,"UP")) S Y=^("UP"),%=$O(^DD(Y,"SB",DICATTA,0)) I %,$P($G(^DD(Y,%,0)),U,2)["A" S Y="NO" Q
S Y="YES"
Q
;
POST ;This is the DATA VALIDATION of the DICATT FORM
N DICATT1N,DICATTM,DICATT4N,DICATT4S,DICATTED,X,T,G,DIC,DIE,DR,DA
K DDSBR,DDSERROR
I DICATT2 G MULEDIT^DICATTDD
VP I $$G(20)=8 D POSTVP^DICATTD8 I $D(DDSBR) S DDSERROR=1,DDSBR=DDSBR_"^DICATT8^2.8" Q
S DICATT1N=$$G(1)
I DICATT1N="" G ^DICATTDK:$D(DICATTDK) S DDSBR=1,DDSERROR=1 Q
I DICATT1N=$$G(2) S DDSERROR=1,DDSBR=1 D HLP^DDSUTL("NAME AND TITLE MUST BE DIFFERENT") Q
I $G(DICATTLN) D I $D(DDSERROR) D HLP^DDSUTL("YOUR REDEFINITION OF THE FIELD WOULD CAUSE TOO MUCH DATA STORAGE!") Q
.N W,DP,N,A,L,Y
.S A=DICATTA,DP=DICATTF,W=$P(^DD(A,DP,0),U,4),Y=$P(W,";"),N=$P(W,";",2),T=0,L=DICATTLN Q:W=""
.D MX^DICATT1
.I $$MAX^DICATTDM(L-T,Y)>251 S DDSERROR=1,DDSBR=20
NEW I DICATT4="",'$D(DICATT4N) D I $D(DDSERROR) D HLP^DDSUTL("DATA-STORAGE INFO INCOMPLETE") Q
.I DICATTF=.001 S DICATT4N=" " Q
.S G=$$G(20) I G=6 S DICATT4N=" ; " Q
.I G=5!$$G(20.5) D Q:$D(DDSERROR) S DICATT4N=DICATTM(76)_";0" Q ;Note that we can $$GET the defaulted values for storage, even if user has not seen Pages 3 or 4
..F T=76,76.1 S DICATTM(T)=$$GET^DDSVALF(T,"DICATTS",4,"","") I DICATTM(T)="" S DDSERROR=1,DDSBR="76^DICATTS^4" Q
.S G=$$GET^DDSVALF(16,"DICATTM",3,"",""),T=$$GET^DDSVALF(17,"DICATTM",3,"","")
.I G=""!(T="") S DDSERROR=1,DDSBR="16^DICATTM^3" Q
.S DICATT4N=G_";"_T Q
S X=^DD(DICATTA,DICATTF,0) D I $D(DDSERROR) D HLP^DDSUTL("FIELD DEFINITION IS TOO LONG!") Q ;Can't fit it into the zero node
.S T=$L(DICATT1N)+$L($S($D(DICATT2N):DICATT2N,1:$P(X,U,2)))+$L($S($D(DICATT3N):DICATT3N,1:$P(X,U,3)))+$L($S($D(DICATT4N):DICATT4N,1:$P(X,U,4)))+$L($S($D(DICATT5N)#2:DICATT5N,1:$P(X,U,5,999)))
.I T>242 S DDSERROR=1
FILE ;Everything's good! We're gonna file it
I $D(DICATT4N) S $P(^DD(DICATTA,DICATTF,0),U,4)=DICATT4N I DICATT4N'?.P S DICATT4S=$P(DICATT4N,";"),^DD(DICATTA,"GL",DICATT4S,$P(DICATT4N,";",2),DICATTF)="" ;new Piece 4
I $D(DICATTM),$D(DICATT4S) D Q ;make a MULTIPLE
.N TYPE S TYPE=$$G(20)
.D MULMAKE^DICATTDD(DICATTM(76.1),TYPE)
WP .I TYPE=5 N DICATTA,DICATTF S:'$D(DICATT2N) DICATT2N="W" ;so we'll bounce back up from W-P multiple
.S DICATTA=DICATTM(76.1),DICATTF=.01,DICATTMN="" D CHANGED ;make the .01 Field of the new multiple
CHANGED S X=$E("R",$$G(18)) I DICATT2["R"'=$L(X)!$D(DICATTMN) D
.S DICATTMN="" K ^DD(DICATTA,"RQ",DICATTF) I X["R" S ^(DICATTF)=""
.I '$D(DICATT2N) S DICATT2N=$TR(DICATT2,"R") I DICATT2["W" S DICATT2N="W"
.S DICATT2N=X_DICATT2N
.S %=$P(DICATT2,"P",2) I % K ^DD(+%,0,"PT",DICATTA,DICATTF) ;remove old PT node
.F %=DICATTA:0 S ^DD(%,0,"DT")=DT Q:'$D(^("UP")) S %=^("UP") Q:'$D(^DD(%))
.S %=$P(DICATT2N,"P",2) I % S ^DD(+%,0,"PT",DICATTA,DICATTF)=""
.I DICATT2N["C" D
..N DICOMPX,A,DA
..S (DA(1),A)=DICATTA,DA=DICATTF,DICOMPX=$G(DICATT5N(9.01)) K ^DD(A,DA,9.02) D ACOMP^DICATT3
.I DICATTF=.01 D
..I DICATTA=DICATTB D Q
...I $D(^DIC(DICATTA,0,"GL")),$D(@(^("GL")_"0)")) D UP2("",DICATT2N)
..S Y=$$GET^DDSVALF(2,"DICATTMUL",5,"I","") I Y?1N S DICATT2N=$E("M",Y=1)_DICATT2N
..S DR=$$GET^DDSVALF(1,"DICATTMUL",5,"I","")
..I $G(^DD(DICATTA,0,"UP")) S Y=^("UP"),%=$O(^DD(Y,"SB",DICATTA,0)) I Y,%,$D(^DD(Y,%,0)) D UP2(DR,DICATT2N) ;Reset the MULTIPLE field at the higher level
.S $P(^DD(DICATTA,DICATTF,0),U,2)=DICATT2N
PIECE3 .I $D(DICATT3N) S $P(^(0),U,3)=$G(DICATT3N)
.I $D(DICATTVP) D FILE^DICATTD8
SCREEN S %=$$GET^DDSVALF(65,"DICATT SCREEN",6,"I",""),X=$P(^DD(DICATTA,DICATTF,0),U,2) I %=0!(%="NO")!(X'["P"&(X'["S")) K ^(12),^(12.1)
F %=8:0 S %=$O(DICATT5N(%)) Q:'% S ^DD(DICATTA,DICATTF,%)=DICATT5N(%)
K ^DD(DICATTA,DICATTF,.009) I $D(DICATT5N)#2 S $P(^(0),U,5,99)=DICATT5N
S DR="50////^S X=DT" F X=1:1:8 D 0
D DIE
S DR="Q",X=98 D 0,DIE
S DR="Q",X=99 D 0,DIE
D FILEWORD^DICATTD0
MUMPS I $P(^DD(DICATTA,DICATTF,0),U,2)["K" S ^(9)="@" ;**151
RESET D GET^DICATTD ;now that we have filed, the NEW is OLD, in case they keep editing!
Q Q
;
UP2(A,X) N T,Y ;A=0 if NO LAYGO X=SPECIFIER
S Y=$P(^(0),U,2),Y=$TR(Y,"SDPV")
F T="S","V","P","D" I X[T S Y=Y_T Q
I A?1N S Y=$TR(Y,"A")_$E("A",DR=0)
S $P(^(0),U,2)=Y
Q
;
0 S T=$T(@X),G=$TR($$G(X),";") Q:G="@"!(G="^") S:G="" G="@" S DR=DR_$P(T,";",2,3)_"////"_G Q ;Re-file NAME, TITLE, etc. Delete if they are now gone. Leave "@" alone
1 ;;.01
2 ;;.1
3 ;;1.1
4 ;;1.2
5 ;;8
6 ;;8.5
7 ;;9
8 ;;10
98 ;;3
99 ;;4
;
DIE S DICATTED=1,DA=DICATTF,DA(1)=DICATTA,(DIC,DIE)="^DD(DICATTA,"
D ^DIE
Q
;
N ;
S DA=DICATTF I $G(DDA(1))]"" S:$G(DICATTA) DDA(1)=DICATTA S:'$D(^DD(DDA(1),DA)) DDA="D" D AUDT^DICATTA
I $D(DIU0) N DI D IJ^DIUTL(DICATTA),P^DICATT
Q
;
G(I) N X Q $$GET^DDSVALF(I,"DICATT",1,"I","")
DICATTDE ;GFT;;END SCREEN EDIT ; 04 Jun 2007 3:39 PM
+1 ;;22.0;VA FileMan;**42,83,103,151**;Mar 30, 1999;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
LAYGODEF ;should user see 'ADDING NEW'?
+1 NEW %
+2 IF DICATTF=.01
IF $GET(^DD(DICATTA,0,"UP"))
SET Y=^("UP")
SET %=$ORDER(^DD(Y,"SB",DICATTA,0))
IF %
IF $PIECE($GET(^DD(Y,%,0)),U,2)["A"
SET Y="NO"
QUIT
+3 SET Y="YES"
+4 QUIT
+5 ;
POST ;This is the DATA VALIDATION of the DICATT FORM
+1 NEW DICATT1N,DICATTM,DICATT4N,DICATT4S,DICATTED,X,T,G,DIC,DIE,DR,DA
+2 KILL DDSBR,DDSERROR
+3 IF DICATT2
GOTO MULEDIT^DICATTDD
VP IF $$G(20)=8
DO POSTVP^DICATTD8
IF $DATA(DDSBR)
SET DDSERROR=1
SET DDSBR=DDSBR_"^DICATT8^2.8"
QUIT
+1 SET DICATT1N=$$G(1)
+2 IF DICATT1N=""
IF $DATA(DICATTDK)
GOTO ^DICATTDK
SET DDSBR=1
SET DDSERROR=1
QUIT
+3 IF DICATT1N=$$G(2)
SET DDSERROR=1
SET DDSBR=1
DO HLP^DDSUTL("NAME AND TITLE MUST BE DIFFERENT")
QUIT
+4 IF $GET(DICATTLN)
Begin DoDot:1
+5 NEW W,DP,N,A,L,Y
+6 SET A=DICATTA
SET DP=DICATTF
SET W=$PIECE(^DD(A,DP,0),U,4)
SET Y=$PIECE(W,";")
SET N=$PIECE(W,";",2)
SET T=0
SET L=DICATTLN
IF W=""
QUIT
+7 DO MX^DICATT1
+8 IF $$MAX^DICATTDM(L-T,Y)>251
SET DDSERROR=1
SET DDSBR=20
End DoDot:1
IF $DATA(DDSERROR)
DO HLP^DDSUTL("YOUR REDEFINITION OF THE FIELD WOULD CAUSE TOO MUCH DATA STORAGE!")
QUIT
NEW IF DICATT4=""
IF '$DATA(DICATT4N)
Begin DoDot:1
+1 IF DICATTF=.001
SET DICATT4N=" "
QUIT
+2 SET G=$$G(20)
IF G=6
SET DICATT4N=" ; "
QUIT
+3 ;Note that we can $$GET the defaulted values for storage, even if user has not seen Pages 3 or 4
IF G=5!$$G(20.5)
Begin DoDot:2
+4 FOR T=76,76.1
SET DICATTM(T)=$$GET^DDSVALF(T,"DICATTS",4,"","")
IF DICATTM(T)=""
SET DDSERROR=1
SET DDSBR="76^DICATTS^4"
QUIT
End DoDot:2
IF $DATA(DDSERROR)
QUIT
SET DICATT4N=DICATTM(76)_";0"
QUIT
+5 SET G=$$GET^DDSVALF(16,"DICATTM",3,"","")
SET T=$$GET^DDSVALF(17,"DICATTM",3,"","")
+6 IF G=""!(T="")
SET DDSERROR=1
SET DDSBR="16^DICATTM^3"
QUIT
+7 SET DICATT4N=G_";"_T
QUIT
End DoDot:1
IF $DATA(DDSERROR)
DO HLP^DDSUTL("DATA-STORAGE INFO INCOMPLETE")
QUIT
+8 ;Can't fit it into the zero node
SET X=^DD(DICATTA,DICATTF,0)
Begin DoDot:1
+9 SET T=$LENGTH(DICATT1N)+$LENGTH($SELECT($DATA(DICATT2N):DICATT2N,1:$PIECE(X,U,2)))+$LENGTH($SELECT($DATA(DICATT3N):DICATT3N,1:$PIECE(X,U,3)))+$LENGTH($SELECT($DATA(DICATT4N):DICATT4N,1:$PIECE(X,U,4)))+$LENGTH(...
... $SELECT($DATA(DICATT5N)#2:DICATT5N,1:$PIECE(X,U,5,999)))
+10 IF T>242
SET DDSERROR=1
End DoDot:1
IF $DATA(DDSERROR)
DO HLP^DDSUTL("FIELD DEFINITION IS TOO LONG!")
QUIT
FILE ;Everything's good! We're gonna file it
+1 ;new Piece 4
IF $DATA(DICATT4N)
SET $PIECE(^DD(DICATTA,DICATTF,0),U,4)=DICATT4N
IF DICATT4N'?.P
SET DICATT4S=$PIECE(DICATT4N,";")
SET ^DD(DICATTA,"GL",DICATT4S,$PIECE(DICATT4N,";",2),DICATTF)=""
+2 ;make a MULTIPLE
IF $DATA(DICATTM)
IF $DATA(DICATT4S)
Begin DoDot:1
+3 NEW TYPE
SET TYPE=$$G(20)
+4 DO MULMAKE^DICATTDD(DICATTM(76.1),TYPE)
WP ;so we'll bounce back up from W-P multiple
IF TYPE=5
NEW DICATTA,DICATTF
IF '$DATA(DICATT2N)
SET DICATT2N="W"
+1 ;make the .01 Field of the new multiple
SET DICATTA=DICATTM(76.1)
SET DICATTF=.01
SET DICATTMN=""
DO CHANGED
End DoDot:1
QUIT
CHANGED SET X=$EXTRACT("R",$$G(18))
IF DICATT2["R"'=$LENGTH(X)!$DATA(DICATTMN)
Begin DoDot:1
+1 SET DICATTMN=""
KILL ^DD(DICATTA,"RQ",DICATTF)
IF X["R"
SET ^(DICATTF)=""
+2 IF '$DATA(DICATT2N)
SET DICATT2N=$TRANSLATE(DICATT2,"R")
IF DICATT2["W"
SET DICATT2N="W"
+3 SET DICATT2N=X_DICATT2N
+4 ;remove old PT node
SET %=$PIECE(DICATT2,"P",2)
IF %
KILL ^DD(+%,0,"PT",DICATTA,DICATTF)
+5 FOR %=DICATTA:0
SET ^DD(%,0,"DT")=DT
IF '$DATA(^("UP"))
QUIT
SET %=^("UP")
IF '$DATA(^DD(%))
QUIT
+6 SET %=$PIECE(DICATT2N,"P",2)
IF %
SET ^DD(+%,0,"PT",DICATTA,DICATTF)=""
+7 IF DICATT2N["C"
Begin DoDot:2
+8 NEW DICOMPX,A,DA
+9 SET (DA(1),A)=DICATTA
SET DA=DICATTF
SET DICOMPX=$GET(DICATT5N(9.01))
KILL ^DD(A,DA,9.02)
DO ACOMP^DICATT3
End DoDot:2
+10 IF DICATTF=.01
Begin DoDot:2
+11 IF DICATTA=DICATTB
Begin DoDot:3
+12 IF $DATA(^DIC(DICATTA,0,"GL"))
IF $DATA(@(^("GL")_"0)"))
DO UP2("",DICATT2N)
End DoDot:3
QUIT
+13 SET Y=$$GET^DDSVALF(2,"DICATTMUL",5,"I","")
IF Y?1N
SET DICATT2N=$EXTRACT("M",Y=1)_DICATT2N
+14 SET DR=$$GET^DDSVALF(1,"DICATTMUL",5,"I","")
+15 ;Reset the MULTIPLE field at the higher level
IF $GET(^DD(DICATTA,0,"UP"))
SET Y=^("UP")
SET %=$ORDER(^DD(Y,"SB",DICATTA,0))
IF Y
IF %
IF $DATA(^DD(Y,%,0))
DO UP2(DR,DICATT2N)
End DoDot:2
+16 SET $PIECE(^DD(DICATTA,DICATTF,0),U,2)=DICATT2N
PIECE3 IF $DATA(DICATT3N)
SET $PIECE(^(0),U,3)=$GET(DICATT3N)
+1 IF $DATA(DICATTVP)
DO FILE^DICATTD8
End DoDot:1
SCREEN SET %=$$GET^DDSVALF(65,"DICATT SCREEN",6,"I","")
SET X=$PIECE(^DD(DICATTA,DICATTF,0),U,2)
IF %=0!(%="NO")!(X'["P"&(X'["S"))
KILL ^(12),^(12.1)
+1 FOR %=8:0
SET %=$ORDER(DICATT5N(%))
IF '%
QUIT
SET ^DD(DICATTA,DICATTF,%)=DICATT5N(%)
+2 KILL ^DD(DICATTA,DICATTF,.009)
IF $DATA(DICATT5N)#2
SET $PIECE(^(0),U,5,99)=DICATT5N
+3 SET DR="50////^S X=DT"
FOR X=1:1:8
DO 0
+4 DO DIE
+5 SET DR="Q"
SET X=98
DO 0
DO DIE
+6 SET DR="Q"
SET X=99
DO 0
DO DIE
+7 DO FILEWORD^DICATTD0
MUMPS ;**151
IF $PIECE(^DD(DICATTA,DICATTF,0),U,2)["K"
SET ^(9)="@"
RESET ;now that we have filed, the NEW is OLD, in case they keep editing!
DO GET^DICATTD
Q QUIT
+1 ;
UP2(A,X) ;A=0 if NO LAYGO X=SPECIFIER
NEW T,Y
+1 SET Y=$PIECE(^(0),U,2)
SET Y=$TRANSLATE(Y,"SDPV")
+2 FOR T="S","V","P","D"
IF X[T
SET Y=Y_T
QUIT
+3 IF A?1N
SET Y=$TRANSLATE(Y,"A")_$EXTRACT("A",DR=0)
+4 SET $PIECE(^(0),U,2)=Y
+5 QUIT
+6 ;
0 ;Re-file NAME, TITLE, etc. Delete if they are now gone. Leave "@" alone
SET T=$TEXT(@X)
SET G=$TRANSLATE($$G(X),";")
IF G="@"!(G="^")
QUIT
IF G=""
SET G="@"
SET DR=DR_$PIECE(T,";",2,3)_"////"_G
QUIT
1 ;;.01
2 ;;.1
3 ;;1.1
4 ;;1.2
5 ;;8
6 ;;8.5
7 ;;9
8 ;;10
98 ;;3
99 ;;4
+1 ;
DIE SET DICATTED=1
SET DA=DICATTF
SET DA(1)=DICATTA
SET (DIC,DIE)="^DD(DICATTA,"
+1 DO ^DIE
+2 QUIT
+3 ;
N ;
+1 SET DA=DICATTF
IF $GET(DDA(1))]""
IF $GET(DICATTA)
SET DDA(1)=DICATTA
IF '$DATA(^DD(DDA(1),DA))
SET DDA="D"
DO AUDT^DICATTA
+2 IF $DATA(DIU0)
NEW DI
DO IJ^DIUTL(DICATTA)
DO P^DICATT
+3 QUIT
+4 ;
G(I) NEW X
QUIT $$GET^DDSVALF(I,"DICATT",1,"I","")
