source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDSLIB.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: 3.9 KB
RevLine 
[613]1DDSLIB ;SFISC/MKO-LIBRARY FUNCTIONS ;01:37 PM 6 Sep 1994
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4FIND(E,C,S) ;Find in expression E, starting from pos S, the char pos
5 ;after the next occurrence of char C, ignoring those within quoted
6 ;strings.
7 N I,J,P
8 S:'$D(S) S=1
9 F D Q:$D(P)
10 . S I=$F(E,C,S),J=$F(E,"""",S)
11 . I 'I S P=I Q
12 . I J,J<I S S=$$AFTQ(E,J-1) Q
13 . S P=I
14 Q P
15 ;
16PIECE(E,C,N1,N2) ;Return the N1th to N2th C-piece of E
17 ;ignoring those within quoted strings
18 ;Start looking from pos 1
19 N I,J,S,F
20 S:'$D(N1) N1=1 Q:'N1
21 S:'$D(N2) N2=N1 Q:N2<N1
22 S S=1 F I=1:1:N1-1 S S=$$FIND(E,C,S) Q:'S
23 Q:'S $S(N1=1:E,1:"")
24 S F=S F I=1:1:N2-N1+1 S F=$$FIND(E,C,F) Q:'F
25 Q:'F $E(E,S,999)
26 Q $E(E,S,F-2)
27 ;
28RPAR(E,S) ;Find in expression E, from char pos S (the position
29 ;of the left paren) the char pos after the right paren,
30 ;ignoring nested parens, or parens within quotes
31 N I,L,P,R
32 S P=1,I=S+1
33 F D Q:'P
34 . S R=$$FIND(E,")",I),L=$$FIND(E,"(",I)
35 . I L,L<R S P=P+1,I=L Q
36 . S P=P-1,I=R
37 Q I
38 ;
39AFTQ(E,I) ;Return character position after quoted string
40 ;E = string, I=character position of first quote
41 S:'$G(I) I=1
42 F S I=$F(E,"""",I+1) Q:$E(E,I)'=""""
43 S:'I I=$L(E)+1
44 Q I
45 ;
46QT(X) ;Return X quoted
47 Q:$G(X)="" """"""
48 S X(X)="",X=$Q(X(""))
49 Q $E(X,3,$L(X)-1)
50 ;
51UQT(X) ;Return quoted string X unquoted
52 Q:$G(X)="" ""
53 S @("X("_X_")=""""")
54 Q $O(X(""))
55 ;
56FIELD(DDP,FLD) ;Get field number
57 N F,P
58 I FLD="" D BLD^DIALOG(202,"field") Q ""
59 S:$E(FLD)="""" FLD=$$UQT($E(FLD,1,$$AFTQ(FLD)-1))
60 S F=FLD,P("FILE")=DDP
61 I FLD'=+$P(FLD,"E") D Q:$G(DIERR) ""
62 . S F=$O(^DD(DDP,"B",FLD,""))
63 . I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
64 ;
65 I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
66 Q F
67 ;
68GETFLD(FD,BK,PG,DDS,DDSPG,DDSBK,DDSFLG) ;Return "DDO,bk#,pg#"
69 ;DDSPG=current page, DDSBK=current block
70 ; -- when block and page are optional
71 ;PG is required only if block order is sent
72 ;DDSFLG["F" means field must be form-only
73 N F,B,P,N
74 I FD?.N.1"."1.N1",".N.1"."1.N,BK="",PG="" Q FD
75 S:$E($G(FD))="""" FD=$$UQT(FD)
76 S:$E($G(BK))="""" BK=$$UQT(BK)
77 S:$E($G(PG))="""" PG=$$UQT(PG)
78 S P=+$G(DDSPG),B=+$G(DDSBK)
79 D @$S($G(PG)]"":"PG",$G(BK)]"":"BK",1:"FD") Q:$G(DIERR) ""
80 Q F_","_B_","_P
81 ;
82PG ;Get internal page number
83 I '$G(DDS) D BLD^DIALOG(3084) Q
84 S N=PG=+$P(PG,"E")
85 I N S P=$O(^DIST(.403,+DDS,40,"B",PG,""))
86 E I PG?1"`".N.1"."1.N S P=+$P(PG,"`",2),N=2
87 E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(PG),""))
88 ;
89 I $D(^DIST(.403,+DDS,40,+P,0))[0 D BLD^DIALOG(3023,$S(N=2:"#",N:"number ",1:"named ")_PG) Q
90 ;
91 I BK="" D Q:$G(DIERR)
92 . S BK=$O(^DIST(.403,+DDS,40,P,40,"AC",""))
93 . I BK="" D BLD^DIALOG(3055,$S(N:"number ",1:"named ")_PG)
94 ;
95BK ;Get internal block number
96 S N=BK=+$P(BK,"E")
97 I N D Q:$G(DIERR)
98 . I P S B=$O(^DIST(.403,+DDS,40,P,40,"AC",BK,"")) Q
99 . D BLD^DIALOG(3085)
100 E I BK?1"`".N.1"."1.N S B=+$P(BK,"`",2),N=2
101 E D Q:$G(DIERR)
102 . S B=$O(^DIST(.404,"B",BK,""))
103 . I B="" D BLD^DIALOG(3051,BK) Q
104 . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
105 ;
106 I P,$D(^DIST(.403,+DDS,40,P,40,+B,0))[0 D Q
107 . N P1
108 . S P1(1)=$S(N=2:"#",N:"order ",1:"")_BK
109 . S P1(2)="number "_$P(^DIST(.403,+DDS,40,P,0),U)_$S($G(^(1))]"":" ("_$P(^(1),U)_")",1:"")
110 . D BLD^DIALOG(3053,.P1)
111 ;
112 I FD="" D Q:$G(DIERR)
113 . S FD=$O(^DIST(.404,B,40,"B",""))
114 . D:FD="" BLD^DIALOG(3071,$P(^DIST(.404,B,0),U))
115 ;
116FD ;Get internal field number
117 I 'B D BLD^DIALOG(3082) Q
118 S N=FD=+$P(FD,"E")
119 I N S F=$O(^DIST(.404,B,40,"B",FD,""))
120 E I FD?1"`".N.1"."1.N S F=+$P(FD,"`",2),N=2
121 E D Q:$G(DIERR)
122 . N X
123 . S FD=$$UPCASE(FD),X=$S($D(^DIST(.404,B,40,"D",FD)):"D",1:"C")
124 . S F=$O(^DIST(.404,B,40,X,FD,""))
125 ;
126 I $D(^DIST(.404,B,40,+F,0))[0 D
127 . N P
128 . S P(1)=$S(N=2:"#",N:"order ",1:"with caption or unique name ")_FD
129 . S P(2)=$P(^DIST(.404,B,0),U)
130 . D BLD^DIALOG(3072,.P)
131 ;
132 I '$G(DIERR),$G(DDSFLG)["F","^2^4^"'[(U_$P($G(^DIST(.404,B,40,+F,0)),U,3)_U) D BLD^DIALOG(3081)
133 Q
134 ;
135UPCASE(X) ;
136 ;Return X in uppercase
137 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.