DICATTDE ;O-OIFO/GFT - END screen edit ;23JUN2017
;;22.2;VA FileMan;**3,2,13**;Jan 05, 2016;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;;GFT;**1,42,83,103,999,1004,1027,1028,1032,1042,1043,1055,1058**
;
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
TOOMUCH .I $$MAX^DICATTDM(L-T,Y)>($G(^DD("STRING_LIMIT"),255)-4) 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>($G(^DD("STRING_LIMIT"),255)-13) 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="" ;make the .01 Field of the new multiple
.D M101 Q
M101 I $G(DICATT2N)["t" M ^DD(DICATTA,DICATTF)=DICATTPM K DICATTPM
S X=$E("R",$$G(18)) I DICATT2["R"'=$L(X)!$D(DICATTMN) D
.F %=DICATTA:0 S ^DD(%,0,"DT")=DT Q:'$D(^("UP")) S %=^("UP") Q:'$D(^DD(%))
.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_$E("I",$G(DICATT2)["I")
.S %=$P(DICATT2,"P",2) I % K ^DD(+%,0,"PT",DICATTA,DICATTF) ;remove old PT node
.S %=$P(DICATT2N,"P",2) I % S ^DD(+%,0,"PT",DICATTA,DICATTF)=""
DIK2 .I DICATT2["t" D AFDEFDEL^DIETLIB(DICATTA,DICATTF)
COMPUTED .I DICATT2N["C" D
..N DICOMPX,A,DA
..S A=+$P(DICATT2,"p",2) I A,$D(^DD(A,0)) K ^(0,"PTC",DICATTA,DICATTF)
..S A=+$P(DICATT2N,"p",2) I A,$D(^DD(A,0)) S ^(0,"PTC",DICATTA,DICATTF)=""
..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 ;SET THE SPECIFIER!
PIECE3 .I $D(DICATT3N) S $P(^(0),U,3)=$G(DICATT3N)
.I $D(DICATTVP) D FILE^DICATTD8
DIK1 .N DIK,DA S DA=DICATTF,DA(1)=DICATTA,DIK="^DD("_DICATTA_",",DIK(1)=.2 D EN1^DIK ;CROSS-REFERENCE THE SPECIFIER!
;
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)
COMPNODS S %=9.2 F K ^DD(DICATTA,DICATTF,%) S %=$O(^(%)) Q:%\1-9 ;KILL ALL THE 9.2 NODES
F %=8:0 S %=$O(DICATT5N(%)) Q:'% S ^DD(DICATTA,DICATTF,%)=DICATT5N(%) ;SET THE 9.2 NODES
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
EGP ;K ^DD(DICATTA,DICATTF,.009) ;WHEN FIELD CHANGES, KILL OFF ITS HELP TRANSLATIONS
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
AUDIT I $G(DICATT2)]"",$P(^(0),U,2)'=DICATT2,$G(^DD(DICATTB,0,"DIK"))]"" D EN2^DIKZ(DICATTB,"",^("DIK")) ;Recompile CROSS-REFS if auditing changes
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","")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTDE 6125 printed Apr 09, 2024@21:49:53 Page 2
DICATTDE ;O-OIFO/GFT - END screen edit ;23JUN2017
+1 ;;22.2;VA FileMan;**3,2,13**;Jan 05, 2016;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;;GFT;**1,42,83,103,999,1004,1027,1028,1032,1042,1043,1055,1058**
+7 ;
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
TOOMUCH IF $$MAX^DICATTDM(L-T,Y)>($GET(^DD("STRING_LIMIT"),255)-4)
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>($GET(^DD("STRING_LIMIT"),255)-13)
SET DDSERROR=1
End DoDot:1
IF $DATA(DDSERROR)
DO HLP^DDSUTL("FIELD DEFINITION IS TOO LONG!")
QUIT
+11 ;
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=""
+2 DO M101
QUIT
End DoDot:1
QUIT
M101 IF $GET(DICATT2N)["t"
MERGE ^DD(DICATTA,DICATTF)=DICATTPM
KILL DICATTPM
+1 SET X=$EXTRACT("R",$$G(18))
IF DICATT2["R"'=$LENGTH(X)!$DATA(DICATTMN)
Begin DoDot:1
+2 FOR %=DICATTA:0
SET ^DD(%,0,"DT")=DT
if '$DATA(^("UP"))
QUIT
SET %=^("UP")
if '$DATA(^DD(%))
QUIT
+3 SET DICATTMN=""
KILL ^DD(DICATTA,"RQ",DICATTF)
IF X["R"
SET ^(DICATTF)=""
+4 IF '$DATA(DICATT2N)
SET DICATT2N=$TRANSLATE(DICATT2,"R")
IF DICATT2["W"
SET DICATT2N="W"
+5 SET DICATT2N=X_DICATT2N_$EXTRACT("I",$GET(DICATT2)["I")
+6 ;remove old PT node
SET %=$PIECE(DICATT2,"P",2)
IF %
KILL ^DD(+%,0,"PT",DICATTA,DICATTF)
+7 SET %=$PIECE(DICATT2N,"P",2)
IF %
SET ^DD(+%,0,"PT",DICATTA,DICATTF)=""
DIK2 IF DICATT2["t"
DO AFDEFDEL^DIETLIB(DICATTA,DICATTF)
COMPUTED IF DICATT2N["C"
Begin DoDot:2
+1 NEW DICOMPX,A,DA
+2 SET A=+$PIECE(DICATT2,"p",2)
IF A
IF $DATA(^DD(A,0))
KILL ^(0,"PTC",DICATTA,DICATTF)
+3 SET A=+$PIECE(DICATT2N,"p",2)
IF A
IF $DATA(^DD(A,0))
SET ^(0,"PTC",DICATTA,DICATTF)=""
+4 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
+5 IF DICATTF=.01
Begin DoDot:2
+6 IF DICATTA=DICATTB
Begin DoDot:3
+7 IF $DATA(^DIC(DICATTA,0,"GL"))
IF $DATA(@(^("GL")_"0)"))
DO UP2("",DICATT2N)
End DoDot:3
QUIT
+8 SET Y=$$GET^DDSVALF(2,"DICATTMUL",5,"I","")
IF Y?1N
SET DICATT2N=$EXTRACT("M",Y=1)_DICATT2N
+9 SET DR=$$GET^DDSVALF(1,"DICATTMUL",5,"I","")
+10 ;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
+11 ;SET THE SPECIFIER!
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
DIK1 ;CROSS-REFERENCE THE SPECIFIER!
NEW DIK,DA
SET DA=DICATTF
SET DA(1)=DICATTA
SET DIK="^DD("_DICATTA_","
SET DIK(1)=.2
DO EN1^DIK
End DoDot:1
+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)
COMPNODS ;KILL ALL THE 9.2 NODES
SET %=9.2
FOR
KILL ^DD(DICATTA,DICATTF,%)
SET %=$ORDER(^(%))
if %\1-9
QUIT
+1 ;SET THE 9.2 NODES
FOR %=8:0
SET %=$ORDER(DICATT5N(%))
if '%
QUIT
SET ^DD(DICATTA,DICATTF,%)=DICATT5N(%)
+2 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
EGP ;K ^DD(DICATTA,DICATTF,.009) ;WHEN FIELD CHANGES, KILL OFF ITS HELP TRANSLATIONS
+1 SET DR="Q"
SET X=98
DO 0
DO DIE
+2 SET DR="Q"
SET X=99
DO 0
DO DIE
+3 DO FILEWORD^DICATTD0
MUMPS ;**151
IF $PIECE(^DD(DICATTA,DICATTF,0),U,2)["K"
SET ^(9)="@"
AUDIT ;Recompile CROSS-REFS if auditing changes
IF $GET(DICATT2)]""
IF $PIECE(^(0),U,2)'=DICATT2
IF $GET(^DD(DICATTB,0,"DIK"))]""
DO EN2^DIKZ(DICATTB,"",^("DIK"))
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","")
