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

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

initial load of WorldVistAEHR

File size: 2.3 KB
RevLine 
[613]1DICATTDM ;GFT ;04:56 PM 17 Dec 2002
2 ;;22.0;VA FileMan;**42,118**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5SUBDEF ;
6 S Y=$O(^DD(DICATTA,"GL",""),-1)
7 I $$CHKSUB(Y) Q
8NXT I Y S Y=Y+1 Q
9 F Y=+$O(^DD(DICATTA,"GL","A"),-1):1 Q:'$D(^(Y))
10 Q
11 ;
12PIECDEF ;
13 I $E($G(DICATT2N))="K" S Y="E1,245" Q
14 S Y=$$G(16) I Y]"" S Y=$$P(Y)
15 Q
16 ;
17P(Y) ;given SUBSCRIPT Y, return PIECE prompt
18 N P,X,%
19 S X=0,%=1,P=0
20PC S X=$O(^DD(DICATTA,"GL",Y,X)) I X'="" S P=$P(X,",",2),%=$S(%>P:%,1:P+1) G PC
21 I P S %="E"_%_","_(DICATTLN+%-1)
22 E S %=$O(^(99999),-1)+1
23 Q %
24 ;
25SUBHELP ;
26 S Y=$E($G(DICATT2N))="K" D UNED^DDSUTL(17,"DICATTM",3,Y)
27 N X,Y,T
28 S X(1)="Enter name of MUMPS Global subscript where this Field's data will be stored."
29 S X(2)="Already assigned:"
30 S Y="",T=3
31 F S Y=$O(^DD(DICATTA,"GL",Y)) Q:Y="" S X(T)=$G(X(T))_$J(Y,9) I $L(X(T))>66 S T=T+1
32 D HLP^DDSUTL(.X)
33 Q
34 ;
35CHKSUB(X) ;used as INPUT TRANSFORM for Fields 16 & 76
36 N M
37 S M=$$GET^DDSVALF(20.5,"DICATT",1,"","")
38 I $D(^DD(DICATTA,"GL",X)),M Q "Another Field is already stored at '"_X_"'"
39 I $D(^(X,0)) Q "A multiple field is already stored at '"_X_"'"
40 I $G(DICATTLN),$$MAX(DICATTLN,X)>250 Q "Too much to store at the '"_X_"' subscript"
41 Q 1
42 ;
43MAX(L,Y) ;given L=length of new data, Y=subscript name
44 N T,A,DP,N,W
45 S A=DICATTA,DP=DICATTF
46 D MAX^DICATT1 Q T ;returns maximum length of subscript's data
47 ;
48CHKPIEC(P) ;
49 N N,S
50 S S=$$G(16) I S="" Q S ;must have subscript
51 I P?1"E"1.N1","1.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'<$G(DICATTLN) Q "Can't be less than "_DICATTLN
52 I P>0,P<100,P?.N,+P=P G USED
53 Q ""
54USED I $D(^DD(DICATTA,"GL",S,P)) Q "Already used for '"_$P(^DD(DICATTA,$O(^(P,0)),0),U)_"'"
55 I P["E",$O(^(0)) Q "Can't store by $EXTRACT in the same subscript with $PIECES"
56 Q 1
57 ;
58PIECHELP ;
59 N X,G,Y,P,T
60 S X(1)="Type a number from 1 to 99"
61 S G=$$G(16) Q:G=""
62 I '$D(^DD(DICATTA,"GL",G)) S X(1)=X(1)_" or an $EXTRACT range such as ""E2,4""." Q
63 S X(1)=X(1)_".",X(2)="Currently assigned: ",Y="",T=2
64 F S Y=$O(^DD(DICATTA,"GL",G,Y)) Q:Y="" S P=$O(^(Y,0)) I $D(^DD(DICATTA,P,0)) S X(T)=$G(X(T))_$J(Y,7) I $L(X(T))>66 S T=T+1
65 D HLP^DDSUTL(.X)
66 Q
67 ;
68POST ;POST-ACTION of Page 3
69 N %
70 S %=$$CHKPIEC($$G(17)) I '% S DDSBR=% K % S %(1)=DDSBR,DDSBR=16 D H(.%)
71 Q
72 ;
73H(%) S %($O(%(""),-1)+1)="$$EOP"
74 D HLP^DDSUTL(.%)
75 Q
76 ;
77G(I) Q $$GET^DDSVALF(I,"DICATTM",3,"","")
Note: See TracBrowser for help on using the repository browser.