source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXSQL5.m@ 645

Last change on this file since 645 was 645, checked in by Sam Habiel, 14 years ago

Initial Import of BMX.net code
File size: 6.7 KB
Line 
1BMXSQL5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
2 ;;2.1;BMX;;Jul 26, 2009
3 ;
4 ;
5SELECT ;EP - Get field names into BMXFLD("NAME")="FILE#^FIELD#"
6 N BMXA,BMXB,BMXS,BMXSINGL
7 N BMXINTNL
8 S T=$G(BMXTK("SELECT"))
9 I '+T S BMXERR="'SELECT' CLAUSE NOT FOUND" D ERRTACK^BMXSQL(1) Q
10 S BMXFLD=0
11 N BMXOFF,BMXGS1,BMXLVL
12 F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("FROM")) I BMXTK(T)'="," S BMXOFF=1,BMXLVL=0 D S1 Q:$D(BMXERR)
13 Q
14 ;
15SALIAS ;
16 Q:'+$O(BMXTK(T))
17 N V
18 S V=T+1
19 Q:$G(BMXTK(V))=","
20 Q:V=$G(BMXTK("FROM"))
21 S:BMXTK(V)["'" BMXTK(V)=$P(BMXTK(V),"'",2)
22 S BMXFLDA(BMXFILE,BMXFLDN)=BMXTK(V)
23 S $P(BMXFLDO(BMXFLDO-1),U,6)=BMXTK(V)
24 S T=T+1
25 Q
26 ;
27S1 ;
28 S BMXTK(T)=$TR(BMXTK(T),"_"," ")
29 ;Check for INTERNAL[ modifier
30 S BMXGS1=0
31 S BMXINTNL="E"
32 I BMXTK(T)["[" S BMXINTNL="I",BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1)
33 ;If explicit file name
34 S BMXSINGL=0
35 I BMXTK(T)["." D G:BMXGS1 S1 G:BMXSINGL NOTEXP Q
36 . ;Before FILE.FIELD Parsing
37 . S BMXA=$P(BMXTK(T),".",1,BMXOFF) ;File Name
38 . I '$D(BMXF(BMXA)) D Q:$D(BMXERR) Q:BMXSINGL
39 . . I $D(^DD(BMXFO(1),"B",BMXTK(T))),BMXOFF=1 S BMXSINGL=1 Q
40 . . S BMXERR="FILE NOT FOUND" D ERRTACK^BMXSQL(1) Q
41 . S BMXB=$P(BMXTK(T),".",1+BMXOFF,99) ;Field Name TODO: Test here for multiple in extended pointer -- FILE.MULTIPLE.FIELD
42 . N BMXLAST S BMXLAST=0
43 . I $L(BMXB,".")>1 D Q:'BMXLAST ;Multiple
44 . . N BMXFNUM,BMXFNAM,BMXFNOD,BMXSUBFN,BMXUPFN,BMXGL,W,BMXFOUND
45 . . ;Multiple or Field-name with period?
46 . . S BMXFOUND=0
47 . . F W=1:1:$L(BMXTK(T),".") D Q:BMXFOUND
48 . . . S BMXOFF=BMXOFF+1
49 . . . I $D(^DD(BMXF(BMXA),"B",$P(BMXB,".",1,W))) D
50 . . . . S BMXFNAM=$P(BMXB,".",1,W)
51 . . . . S BMXFOUND=1
52 . . . . S:W=$L(BMXB,".") BMXLAST=1
53 . . . . S BMXLVL=BMXLVL+1
54 . . ;
55 . . Q:BMXLAST
56 . . S BMXF=BMXF+1
57 . . S BMXFNUM=$O(^DD(BMXF(BMXA),"B",BMXFNAM,0)) ;FieldNumber
58 . . S BMXFNOD=^DD(BMXF(BMXA),BMXFNUM,0)
59 . . S BMXGL=$P(BMXFNOD,U,4),BMXGL=$P(BMXGL,";")
60 . . S BMXSUBFN=+$P(BMXFNOD,U,2) ;Subfile Number
61 . . S BMXUPFN=^DD(BMXSUBFN,0,"UP") ;Parent File Number
62 . . D SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXLVL,0)
63 . . S BMXGS1=1
64 . S:BMXB["'" BMXB=$P(BMXB,"'",2)
65 . I BMXB="BMXIEN" D Q
66 . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
67 . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
68 . . D SELECT1
69 . I BMXB="*" D Q ;All fields in file BMXA
70 . . ;BMXIEN Has to be first because ADO doesn't handle it well if a DATE type column is returned first
71 . . S BMXB="BMXIEN"
72 . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
73 . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
74 . . D SELECT1
75 . . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D
76 . . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
77 . . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
78 . . . D SELECT1
79 . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
80 . I '$D(^DD(BMXF(BMXA),"B",BMXB)) S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
81 . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
82 . D SELECT1
83 . Q
84 ;
85NOTEXP ;File not explicit so Loop through files in BMXF to locate field name
86 ;
87 I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2)
88 S C=0,BMXA=""
89 I BMXTK(T)="BMXIEN" D Q
90 . S BMXB=BMXTK(T)
91 . S BMXA=BMXFO(1) ;File defaults to first named file in FROM
92 . S BMXA=BMXFNX(BMXA)
93 . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
94 . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
95 . D SELECT1
96 F S BMXA=$O(BMXF(BMXA)) Q:BMXA="" D Q:$D(BMXERR)
97 . S BMXB=BMXTK(T)
98 . I BMXB="*" D Q ;All fields in file BMXA
99 . . S BMXB="BMXIEN"
100 . . S BMXA=BMXFO(1) ;File defaults to first named file in FROM
101 . . S BMXA=BMXFNX(BMXA)
102 . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
103 . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
104 . . D SELECT1
105 . . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D
106 . . . S BMXS=BMXA_"."_BMXB
107 . . . S BMXFLD(BMXS)=BMXF(BMXA)
108 . . . S $P(BMXFLD(BMXS),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
109 . . . D SELECT1
110 . . . S C=1
111 . I $D(^DD(BMXF(BMXA),"B",BMXTK(T))) D Q:$D(BMXERR)
112 . . S C=C+1
113 . . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERRTACK^BMXSQL(1) Q
114 . . S BMXB=BMXTK(T) ;Field Name
115 . . I BMXB["'" S BMXB=$P(BMXB,"'",2)
116 . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
117 . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
118 . . D SELECT1
119 . . Q
120 . Q
121 I C=0 S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
122 Q
123 ;
124SELECT1 ;
125 N BMXGNOD,BMXFILE,BMXGNOD1
126 S BMXFLDN=$P(BMXFLD(BMXA_"."_BMXB),"^",2)
127 S BMXFILE=$P(BMXFLD(BMXA_"."_BMXB),U)
128 S BMXFLDN(BMXFILE,BMXFLDN)=BMXB
129 I BMXFLDN=".001" S BMXGNOD="IEN",BMXGNOD1="",$P(BMXGNOD1,U,2)="N"
130 E S BMXGNOD1=^DD(BMXFILE,BMXFLDN,0)
131 S BMXGNOD=$P(BMXGNOD1,"^",4)
132 S $P(BMXFLD(BMXA_"."_BMXB),"^",3)=$P(BMXGNOD,";")
133 S $P(BMXFLD(BMXA_"."_BMXB),"^",4)=$P(BMXGNOD,";",2)
134 S $P(BMXFLD(BMXA_"."_BMXB),"^",5)=BMXINTNL
135 S BMXFLDO(BMXFLD)=BMXFILE_"^"_BMXFLDN_"^"_BMXINTNL
136 I +$P(BMXGNOD1,U,2) D ;Check for WP
137 . S BMXGNOD1=+$P(BMXGNOD1,U,2)
138 . Q:'$D(^DD(BMXGNOD1,.01,0))
139 . I $P(^DD(BMXGNOD1,.01,0),U,2)["W" S $P(BMXFLDO(BMXFLD),U,4)="W"
140 ;HMW20030630 Modified next line to make data type of Internal[] for pointer an Integer.
141 I $P(BMXGNOD1,U,2)["P" S BMXGNOD1=$$PTYPE(BMXGNOD1) Q:BMXGNOD1="" S:$G(BMXINTNL)="I" $P(BMXGNOD1,U,2)="N" ;I BMXGNOD1="" then Pointed-to file doesn't exist
142 I $P(BMXGNOD1,U,2)["D" S $P(BMXFLDO(BMXFLD),U,5)="D"
143 I $P(BMXGNOD1,U,2)["N" D
144 . N Z
145 . S Z=$P(BMXGNOD1,U,2)
146 . I +$P(Z,",",2)=0 S $P(BMXFLDO(BMXFLD),U,5)="I" ;Integer
147 S BMXFLDOX(BMXFILE,BMXFLDN,BMXINTNL)=BMXFLD
148 S BMXFLD=BMXFLD+1
149 S BMXFLDO=BMXFLD
150 D SALIAS
151 Q
152 ;
153SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXOFF,BMXOTM) ;EP
154 ;
155 ;BMXOTM = One-To-Many
156 N BMXUPG
157 S BMXMFL("PARENT",BMXSUBFN)=BMXUPFN
158 S BMXMFL(BMXUPFN,"SUBFILE",BMXSUBFN)=""
159 S BMXMFL("SUBFILE",BMXUPFN,BMXSUBFN)=""
160 S BMXUPG=BMXMFL(BMXUPFN,"GLOC") ;Parent File Global Set in FROM clause
161 S BMXFNAM=BMXA_"."_BMXFNAM ;TODO: Regression test this line with OTM
162 I 'BMXOTM S BMXMFL(BMXSUBFN,"GLOC")=BMXUPG_"IEN"_(BMXOFF-1)_","_$C(34)_BMXGL_$C(34)_","
163 E S BMXMFL(BMXSUBFN,"GLOC")=BMXGL,BMXMFL(BMXSUBFN,"OTM")=""
164 S BMXMFL(BMXSUBFN,"MULT")="S IEN"_BMXOFF_"=0 F S IEN"_BMXOFF_"=$O("_BMXMFL(BMXSUBFN,"GLOC")_"IEN"_BMXOFF_")) Q:'+IEN"_BMXOFF_" "
165 I $D(BMXMFL(BMXUPFN,"MULT")) S BMXMFL(BMXSUBFN,"MULT")=BMXMFL(BMXUPFN,"MULT")_" "_BMXMFL(BMXSUBFN,"MULT")
166 I 'BMXOTM S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" F J=0:1:"_BMXOFF_" S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
167 E S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" S J=1 S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
168 S BMXMFL(BMXSUBFN,"EXEC")=BMXMFL(BMXSUBFN,"MULT")_"X BMXMFL(BMXFN,""IENS"")"_" D GETS^DIQ(BMXFN,BMXIENS,BMXGF(BMXFN),""E"",BMXA) D SETIEN(IEN"_BMXOFF_",BMXFN)"
169 D F1^BMXSQL(BMXF,BMXFNAM,BMXSUBFN)
170 ;
171 Q
172 ;
173PTYPE(BMXGNOD1) ;
174 ;Traverse pointer chain to retrieve data type of pointed-to field
175 N BMXFILE
176 I $P(BMXGNOD1,U,2)'["P" Q BMXGNOD1
177 S BMXFILE=$P(BMXGNOD1,U,2)
178 S BMXFILE=+$P(BMXFILE,"P",2)
179 S BMXGNOD1=$G(^DD(BMXFILE,".01",0))
180 S BMXGNOD1=$$PTYPE(BMXGNOD1)
181 Q BMXGNOD1
Note: See TracBrowser for help on using the repository browser.