source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATTDE.m@ 1073

Last change on this file since 1073 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1DICATTDE ;GFT;;END SCREEN EDIT ; 04 Jun 2007 3:39 PM
2 ;;22.0;VA FileMan;**42,83,103,151**;Mar 30, 1999;Build 10
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5LAYGODEF ;should user see 'ADDING NEW'?
6 N %
7 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
8 S Y="YES"
9 Q
10 ;
11POST ;This is the DATA VALIDATION of the DICATT FORM
12 N DICATT1N,DICATTM,DICATT4N,DICATT4S,DICATTED,X,T,G,DIC,DIE,DR,DA
13 K DDSBR,DDSERROR
14 I DICATT2 G MULEDIT^DICATTDD
15VP I $$G(20)=8 D POSTVP^DICATTD8 I $D(DDSBR) S DDSERROR=1,DDSBR=DDSBR_"^DICATT8^2.8" Q
16 S DICATT1N=$$G(1)
17 I DICATT1N="" G ^DICATTDK:$D(DICATTDK) S DDSBR=1,DDSERROR=1 Q
18 I DICATT1N=$$G(2) S DDSERROR=1,DDSBR=1 D HLP^DDSUTL("NAME AND TITLE MUST BE DIFFERENT") Q
19 I $G(DICATTLN) D I $D(DDSERROR) D HLP^DDSUTL("YOUR REDEFINITION OF THE FIELD WOULD CAUSE TOO MUCH DATA STORAGE!") Q
20 .N W,DP,N,A,L,Y
21 .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=""
22 .D MX^DICATT1
23 .I $$MAX^DICATTDM(L-T,Y)>251 S DDSERROR=1,DDSBR=20
24NEW I DICATT4="",'$D(DICATT4N) D I $D(DDSERROR) D HLP^DDSUTL("DATA-STORAGE INFO INCOMPLETE") Q
25 .I DICATTF=.001 S DICATT4N=" " Q
26 .S G=$$G(20) I G=6 S DICATT4N=" ; " Q
27 .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
28 ..F T=76,76.1 S DICATTM(T)=$$GET^DDSVALF(T,"DICATTS",4,"","") I DICATTM(T)="" S DDSERROR=1,DDSBR="76^DICATTS^4" Q
29 .S G=$$GET^DDSVALF(16,"DICATTM",3,"",""),T=$$GET^DDSVALF(17,"DICATTM",3,"","")
30 .I G=""!(T="") S DDSERROR=1,DDSBR="16^DICATTM^3" Q
31 .S DICATT4N=G_";"_T Q
32 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
33 .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)))
34 .I T>242 S DDSERROR=1
35FILE ;Everything's good! We're gonna file it
36 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
37 I $D(DICATTM),$D(DICATT4S) D Q ;make a MULTIPLE
38 .N TYPE S TYPE=$$G(20)
39 .D MULMAKE^DICATTDD(DICATTM(76.1),TYPE)
40WP .I TYPE=5 N DICATTA,DICATTF S:'$D(DICATT2N) DICATT2N="W" ;so we'll bounce back up from W-P multiple
41 .S DICATTA=DICATTM(76.1),DICATTF=.01,DICATTMN="" D CHANGED ;make the .01 Field of the new multiple
42CHANGED S X=$E("R",$$G(18)) I DICATT2["R"'=$L(X)!$D(DICATTMN) D
43 .S DICATTMN="" K ^DD(DICATTA,"RQ",DICATTF) I X["R" S ^(DICATTF)=""
44 .I '$D(DICATT2N) S DICATT2N=$TR(DICATT2,"R") I DICATT2["W" S DICATT2N="W"
45 .S DICATT2N=X_DICATT2N
46 .S %=$P(DICATT2,"P",2) I % K ^DD(+%,0,"PT",DICATTA,DICATTF) ;remove old PT node
47 .F %=DICATTA:0 S ^DD(%,0,"DT")=DT Q:'$D(^("UP")) S %=^("UP") Q:'$D(^DD(%))
48 .S %=$P(DICATT2N,"P",2) I % S ^DD(+%,0,"PT",DICATTA,DICATTF)=""
49 .I DICATT2N["C" D
50 ..N DICOMPX,A,DA
51 ..S (DA(1),A)=DICATTA,DA=DICATTF,DICOMPX=$G(DICATT5N(9.01)) K ^DD(A,DA,9.02) D ACOMP^DICATT3
52 .I DICATTF=.01 D
53 ..I DICATTA=DICATTB D Q
54 ...I $D(^DIC(DICATTA,0,"GL")),$D(@(^("GL")_"0)")) D UP2("",DICATT2N)
55 ..S Y=$$GET^DDSVALF(2,"DICATTMUL",5,"I","") I Y?1N S DICATT2N=$E("M",Y=1)_DICATT2N
56 ..S DR=$$GET^DDSVALF(1,"DICATTMUL",5,"I","")
57 ..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
58 .S $P(^DD(DICATTA,DICATTF,0),U,2)=DICATT2N
59PIECE3 .I $D(DICATT3N) S $P(^(0),U,3)=$G(DICATT3N)
60 .I $D(DICATTVP) D FILE^DICATTD8
61SCREEN 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)
62 F %=8:0 S %=$O(DICATT5N(%)) Q:'% S ^DD(DICATTA,DICATTF,%)=DICATT5N(%)
63 K ^DD(DICATTA,DICATTF,.009) I $D(DICATT5N)#2 S $P(^(0),U,5,99)=DICATT5N
64 S DR="50////^S X=DT" F X=1:1:8 D 0
65 D DIE
66 S DR="Q",X=98 D 0,DIE
67 S DR="Q",X=99 D 0,DIE
68 D FILEWORD^DICATTD0
69MUMPS I $P(^DD(DICATTA,DICATTF,0),U,2)["K" S ^(9)="@" ;**151
70RESET D GET^DICATTD ;now that we have filed, the NEW is OLD, in case they keep editing!
71Q Q
72 ;
73UP2(A,X) N T,Y ;A=0 if NO LAYGO X=SPECIFIER
74 S Y=$P(^(0),U,2),Y=$TR(Y,"SDPV")
75 F T="S","V","P","D" I X[T S Y=Y_T Q
76 I A?1N S Y=$TR(Y,"A")_$E("A",DR=0)
77 S $P(^(0),U,2)=Y
78 Q
79 ;
800 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
811 ;;.01
822 ;;.1
833 ;;1.1
844 ;;1.2
855 ;;8
866 ;;8.5
877 ;;9
888 ;;10
8998 ;;3
9099 ;;4
91 ;
92DIE S DICATTED=1,DA=DICATTF,DA(1)=DICATTA,(DIC,DIE)="^DD(DICATTA,"
93 D ^DIE
94 Q
95 ;
96N ;
97 S DA=DICATTF I $G(DDA(1))]"" S:$G(DICATTA) DDA(1)=DICATTA S:'$D(^DD(DDA(1),DA)) DDA="D" D AUDT^DICATTA
98 I $D(DIU0) N DI D IJ^DIUTL(DICATTA),P^DICATT
99 Q
100 ;
101G(I) N X Q $$GET^DDSVALF(I,"DICATT",1,"I","")
Note: See TracBrowser for help on using the repository browser.