BMXSQL ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;4.0;BMX;;JUN 28, 2010
;
;
Q
;
FLDNDX(BMXGBL,BMXFL,BMXFLD) ;
;Returns index name and set code for all indexes on field
;on field BMXFLD in file BMXFL
S BMX31=$C(31)_$C(31)
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
I +BMXFL'=BMXFL D
. S BMXFL=$TR(BMXFL,"_"," ")
. I '$D(^DIC("B",BMXFL)) S BMXFL="" Q
. S BMXFL=$O(^DIC("B",BMXFL,0))
I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
;
;Check for field name
I +BMXFLD'=BMXFLD D
. S BMXFLD=$TR(BMXFLD,"_"," ")
. I '$D(^DD(BMXFL,"B",BMXFLD)) S BMXFLD="" Q
. S BMXFLD=$O(^DD(BMXFL,"B",BMXFLD,0))
I '$G(BMXFLD) D ERROUT("Field not provided",1) Q
;
;Set up Column names
S ^BMXTEMP($J,0)="T"_$$NUMCHAR(30)_"INDEX^T"_$$NUMCHAR(200)_"CODE"_$C(30)
;
;Write field data to BMXTEMP
S BMXI=0,I=0
N BMXNAM,BMXCOD,BMXNOD,BMXTYP
F S BMXI=$O(^DD(BMXFL,BMXFLD,1,BMXI)) Q:'+BMXI Q:$D(BMXERR) D
. S I=I+1
. S BMXNOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,0))
. S BMXNAM=$P(BMXNOD,U,2)
. S BMXTYP=$P(BMXNOD,U,3)
. S:BMXTYP="" BMXTYP="REGULAR"
. S BMXCOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,1))
. S BMXCOD=$TR(BMXCOD,"^","~")
. S ^BMXTEMP($J,I)=BMXNAM_U_BMXTYP_U_BMXCOD_$C(30)
Q
;
TLIST(BMXGBL,BMXFROM,BMXTO) ;
;Returns list of Fileman files to which user has READ access
;TODO: Pass in type of access (RD,DL,WR) in BMXPAR
;
N A,F,BMXF,BMXFLD,D0,BMXU,I,BMXCNT,BMXMFL,BMXRD,BMXMAX
S U="^"
S:$G(BMXFROM)="RD" BMXFROM=""
K ^BMXTMP($J),^BMXTEMP($J)
S BMXGBL="^BMXTEMP("_$J_")"
S BMXF=1
S BMXF("FILE")=1
S BMXFLD("FILE")="1^.01"
S BMXFLD("NUMBER")="1^.001" ;ADDED
S BMXFLDN=$P(BMXFLD("FILE"),"^",2)
S BMXFLDN(1,BMXFLDN)="FILE"
S BMXFLDN=$P(BMXFLD("NUMBER"),"^",2) ;ADDED
S BMXFLDN(1,BMXFLDN)="NUMBER" ;ADDED
S BMXFLDO=2 ;CHANGED FROM 1 TO 2
S BMXFLDO(0)="1^.01"
S BMXFLDOX(1,.01,"E")=0
S BMXFLDO(1)="1^.001" ;ADDED
S BMXFLDOX(1,.001,"E")=1 ;ADDED
S BMXFNX(1)="FILE"
S BMXFO(1)="1"
S BMXU=$G(DUZ(0))
S BMXRD=$C(30)
S ^BMXTEMP($J,0)="T00030FILE^N00010NUMBER"_BMXRD
S BMXSET="S I=I+1,^BMXTEMP($J,I)=$P($G(^DIC(D0,0)),U)_U_D0_BMXRD,BMXCNT=BMXCNT+1"
S D0=0,I=0,BMXCNT=0,BMXMAX=2000
S BMXFROM=$G(BMXFROM),BMXTO=$G(BMXTO)
I +BMXFROM=BMXFROM D ;BMXFROM is a filenumber
. S F=(+BMXFROM-1),T=+BMXTO
. S:BMXTO<BMXFROM BMXTO=BMXFROM+1
. S D0=F F S D0=$O(^DIC(D0)) Q:'+D0 Q:D0>T Q:BMXCNT>BMXMAX I $D(^DD(D0)) D TLIST1
I +BMXFROM'=BMXFROM D ;F is a filename or is null
. S F="",T="zzzzzzz"
. S:$G(BMXFROM)]"" F=$O(^DIC("B",BMXFROM),-1)
. S:$G(BMXTO)]"" T=BMXTO
. F S F=$O(^DIC("B",F)) Q:F="" Q:F]T Q:BMXCNT>BMXMAX D
. . S D0=0 F S D0=$O(^DIC("B",F,D0)) Q:'+D0 D TLIST1
;
S I=I+1,^BMXTEMP($J,I)=$C(31)
Q
;
TLIST1 ;
I BMXU="@" X BMXSET Q
Q:$D(^DIC(D0,0))'=11
S A=$G(^DIC(D0,0,"RD"))
I $D(^VA(200,DUZ,"FOF",D0,0)) D Q
. ;I $P(^(0),U,5)="1" X BMXSET Q
. I $P(^VA(200,DUZ,"FOF",D0,0),U,5)="1" X BMXSET Q
F J=1:1:$L(A) I DUZ(0)[$E(A,J) X BMXSET
Q
;
SQLCOL(BMXGBL,BMXSQL) ;EP
D INTSQL(.BMXGBL,.BMXSQL,1)
Q
;
SQLD(BMXGBL,BMXSQL) ;EP Serenji Debug Entrypoint
;D DEBUG^%Serenji("SQLD^BMXSQL(.BMXGBL,.BMXSQL)")
Q
;
SQL(BMXGBL,BMXSQL) ;EP
D INTSQL(.BMXGBL,.BMXSQL,0)
Q
;
INTSQL(BMXGBL,BMXSQL,BMXCOL) ;EP
;
;SQL Top Wait for debug break
;D
;. F J=1:1:10 S K=$H H 1
;. Q
;
S X="ERRTRAP^BMXSQL",@^%ZOSF("TRAP")
I $G(BMXSQL)="" S BMXSQL="" D
. N C S C=0 F S C=$O(BMXSQL(C)) Q:'+C D
. . S BMXSQL=BMXSQL_BMXSQL(C)
;
I BMXSQL["call SHAPE" S BMXSQL="SELECT JUNKNAME, MULTCOLOR FROM JUNKMULT"
; Global-scope variables
K BMXTK
N BMXF,BMXTK,T,BMXFLD,BMXTMP,BMXM,BMXXMAX,BMXFLDN,BMXV
N BMXX,BMXFG,BMXFF,BMXSCR,BMXPFP
N BMXERR,BMXFLDO,BMXFLDOX,BMXFJ,BMXFO,BMXFNX
N BMXMFL,BMXFLDA
D ^XBKVAR
S U="^"
I $D(^%ZOSF("MAXSIZ")) S X=640 X ^%ZOSF("MAXSIZ")
K ^BMXTMP($J),^BMXTEMP($J),^BMXTMPD($J)
S BMXGBL="^BMXTEMP("_$J_")"
;Remove CR and LF from BMXSQL
S BMXSQL=$TR(BMXSQL,$C(13)," ")
S BMXSQL=$TR(BMXSQL,$C(10)," ")
S BMXSQL=$TR(BMXSQL,$C(9)," ")
S BMXSQL=$TR(BMXSQL,$C(34),"")
D PARSE^BMXPRS(BMXSQL)
S BMXXMAX=1000000 ;Default Maximum records to return.
D KW^BMXSQL1(.BMXTK)
Q:$D(BMXERR)
;
;Get file names into BMXF("NAME")="NUMBER"
;Get file numbers into BMXFNX(NUMBER)="NAME"
; Files are ordered in BMXFO(order)="NUMBER"
;
FROM S T=$G(BMXTK("FROM"))
I '+T S BMXERR="'FROM' CLAUSE NOT FOUND" D ERROR Q
S BMXF=0
F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("WHERE")) Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR)
. Q:BMXTK(T)=","
. N BMXFNT
. I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2)
. S BMXTK(T)=$TR(BMXTK(T),"_"," ")
. I '(BMXTK(T)?.N),'$D(^DIC("B",BMXTK(T))) S BMXERR="FILE NOT FOUND" D ERROR Q
. S BMXF=BMXF+1
. I BMXTK(T)?.N S BMXFNT=BMXTK(T)
. E S BMXFNT=$O(^DIC("B",BMXTK(T),0))
. S BMXMFL(BMXFNT,"GLOC")=^DIC(BMXFNT,0,"GL")
. D F1(BMXF,BMXTK(T),BMXFNT)
. I '+BMXF(BMXTK(T)) S BMXERR="FILE NUMBER NOT FOUND" D ERROR Q
. D ;Test alias
. . Q:'+$O(BMXTK(T))
. . N V
. . S V=T+1
. . Q:$G(BMXTK(V))=","
. . Q:V=$G(BMXTK("WHERE"))
. . Q:V=$G(BMXTK("ORDER BY"))
. . Q:V=$G(BMXTK("GROUP BY"))
. . S BMXTK(T,"ALIAS")=BMXTK(V)
. . K BMXTK(V)
. . Q
. Q
;
D SELECT^BMXSQL5
I $D(BMXERR) G END
D POST2^BMXPRS ;Remove commas from BMXTK
D KW^BMXSQL1(.BMXTK)
;
D WHERE^BMXSQL7
;
;Find the first WHERE field that has an index
I $D(BMXERR) G END
;
D INDEX(.BMXFF,.BMXX,.BMXTMP)
;
S:BMXTMP BMXX=BMXTMP
;
;Set up screen logic for where fields
D SCREEN^BMXSQL1
D SETX^BMXSQL2(.BMXX,.BMXFG,.BMXSCR)
;
;
EXEC ;Execute enumerator and screen code to call Output routine
;
N BMXOUT,J,BMXC
S BMXOUT=0
;Debug lines (retain):
;K ^HW("BMXX") S J=0 F S J=$O(BMXX(J)) Q:'+J S ^HW("BMXX",J)=BMXX(J)
;K ^HW("BMXSCR") S ^HW("BMXSCR")=$G(BMXSCR) S J=0 F S J=$O(BMXSCR(J)) Q:'+J S ^HW("BMXSCR",J)=BMXSCR(J)
;Test for SHOWPLAN
I $G(BMXTK("SHOWPLAN"))="TRUE" D WPLAN Q
S BMXM=0
I 'BMXCOL S J=0 F S J=$O(BMXX(J)) Q:'+J D Q:BMXM>BMXXMAX
. X BMXX(J)
;
D WRITE^BMXSQL6
;
END Q
;
;
F1(BMXC,BMXNAM,BMXNUM) ;EP
S BMXF(BMXNAM)=BMXNUM
S BMXFNX(BMXNUM)=BMXNAM
S BMXFO(BMXC)=BMXF(BMXNAM)
Q
;
OUT ;Set result in ^BMXTMP
S BMXOUT=BMXOUT+1
S ^BMXTMP($J,"O",D0)=""
S ^BMXTMP($J,BMXOUT)=D0
S BMXM=BMXM+1
Q
;
WPLAN ;Write execution plan
;Set up Column Names
N BMXLEN,BMXTYP,BMXT,J,BMXSCRT,BMXXT
S I=1
F BMXT="VARIABLE^","VALUE"_$C(30) D
. S ^BMXTEMP($J,I)=BMXT,BMXLEN(I)=15,BMXTYP(I)="T"
. S I=I+1
S J=0
I $D(BMXX) F S J=$O(BMXX(J)) Q:'+J D
. S ^BMXTEMP($J,I)="INDEX("_J_")^"
. S I=I+1
. S BMXXT(J)=BMXX(J)
. S BMXXT(J)=$P(BMXXT(J)," X BMXSCR")
. S ^BMXTEMP($J,I)=$TR(BMXXT(J),"^","~")_$C(30)
. S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
. S I=I+1
S ^BMXTEMP($J,I)="SCREEN^"
S I=I+1
S BMXSCRT=$G(BMXSCR)
S BMXSCRT=$P(BMXSCRT,"D:'$D(^BMXTMP")
S ^BMXTEMP($J,I)=$TR(BMXSCRT,"^","~")_$C(30)
S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
S I=I+1
S J=0
I $D(BMXSCR("C")) F S J=$O(BMXSCR("C",J)) Q:'+J D
. S ^BMXTEMP($J,I)="SCREEN("_J_")^"
. S I=I+1
. S ^BMXTEMP($J,I)=$TR(BMXSCR("C",J),"^","~")_$C(30)
. S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I))
. S I=I+1
D COLTYPE
S I=I+1
D ERRTACK(I)
Q
;
;
COLTYPE ;EP - Append column types and widths to output global
;REQUIRES - BMXLEN(),BMXTYP(),^BMXTEMP
;IHS/SET/HMW 4-22-2004 Modified to use new schema string
;
;"@@@meta@@@BMXIEN|FILE #|DA STRING"
;
N C
S C=0
F S C=$O(BMXLEN(C)) Q:'C D
. I BMXLEN(C)>99999 S BMXLEN(C)=99999
. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length
. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
Q
;
;S ^BXTEMP($J,0)="@@@meta@@@BMXIEN|"_BMXF_"|" ;Last |-piece will be DA string
;N C
;S C=0
;F S C=$O(BMXLEN(C)) Q:'C D
;. I BMXLEN(C)>99999 S BMXLEN(C)=99999
;. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length
;. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
;Q
;
ERRTACK(I) ;EP
;
S ^BMXTEMP($J,I)=$C(31)
S:$D(BMXERR) ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXERR
Q
;
NUMCHAR(BMXN) ;EP
;---> Returns Field Length left-padded with 0
;
N BMXC
S BMXC="00000"_BMXN
Q $E(BMXC,$L(BMXC)-4,$L(BMXC))
;
;
INDEX(BMXFF,BMXRET,BMXXCNT) ;
;Returns executable enumerator on first where field with an index
;or "" if no indexed where field
;IN: BMXFF()
;OUT: BMXRET()
; BMXXCNT - size of BMXRET array
;
N F,BMXNOD,BMXFNUM,BMXFLDNM,BMXHIT,BMXREF,BMXRNAM,BMXOP,Q,BMXGL
N BMXTMP,BMXTMPV,BMXTMPI,BMXTMPL,BMXTMPN,BMXV,BMXRNOD,BMXTMPP
S BMXXCNT=0
S Q=$C(34)
I 'BMXFF Q
S F=0,BMXHIT=0
;
;--->Search BMXFF for special case WHERE clause 1 = "0"
; reset BMXX(1) to return no records
F F=1:1:BMXFF S BMXNOD=BMXFF(F) D Q:$D(BMXERR) Q:BMXHIT
. I ($P(BMXFF(F),"^",2,4)="1^=^0")!($P(BMXFF(F),"^",2,4)="0^=^1") S BMXRET(1)="Q ",BMXHIT=1,BMXXCNT=1
. Q
Q:BMXHIT
;
;Organize the first level into AND- and OR-parts
N BMXR1,BMXR2,BMXE,BMXR3,BMXRNAM
N BMXSTOP,BMXOR
D PLEVEL^BMXSQL3(.BMXFF,.BMXR1,.BMXR2)
;
N BMXPFF S BMXPFF=0
S BMXR3=0
;Look for an AND-part with only one element.
; If found, build an iterator on it and quit
F J=1:1:$L(BMXR2,"&") D Q:BMXHIT
. S BMXE=$P(BMXR2,"&",J)
. I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D
. . ;Test index for element
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q ;I'm not sure why this quit was here
. . . Q:$D(BMXFF(K,"JOIN"))
. . . S BMXPFP=K,BMXPFF=0
. . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
. . . I BMXR3 S BMXHIT=1,BMXFF(K,"INDEXED")=1
. Q:'BMXHIT
. ;Build iterator and quit
. D BLDIT^BMXSQL3(.BMXFF,K,.BMXRNAM,.BMXOR,.BMXPFP)
. S BMXXCNT=1
. S BMXRET(BMXXCNT)=BMXOR
. Q
Q:BMXHIT
;
;None of the single-element AND parts has a good index or
; there are no single-element AND parts
;If there are no OR-parts, then there are no good indexes so quit
I $L(BMXR2,"!")=1 Q
;
;Test each OR-part for a good index.
;If an OR-part is multi-element or
;if one OR-part doesn't have an index
;then set up to do a table scan and quit
S BMXSTOP=0
F J=1:1:$L(BMXR2,"!") D Q:BMXSTOP
. S BMXE=$P(BMXR2,"!",J)
. I +BMXE=BMXE D
. . I BMXR1(BMXE,"ELEMENTS")'=1 S BMXSTOP=1 Q ;Multiple elements
. . ;Test index elements
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q
. . . S BMXPFP=K,BMXPFF=0
. . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
. . . I 'BMXR3 S BMXSTOP=1 Q
. . . S BMXFF(K,"INDEXED")=1
. . . S BMXR1(BMXE,"XREF")=BMXRNAM
;
;Build iterator and quit
I BMXSTOP D Q ;One of the elements had no index
. S J=0 F S J=$O(BMXFF(J)) Q:'+J K BMXFF(J,"INDEXED")
S BMXXCNT=0
F J=1:1:$L(BMXR2,"!") D
. S BMXE=$P(BMXR2,"!",J)
. I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D
. . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q
. . . D BLDIT^BMXSQL3(.BMXFF,K,BMXR1(BMXE,"XREF"),.BMXOR,.BMXPFP)
. . . S BMXXCNT=BMXXCNT+1
. . . S BMXRET(BMXXCNT)=BMXOR
. Q
Q
;
;
;
ERROR ;EP - Error processing
;W !,BMXERR
;N A
;S A=0
;I $D(I) S A=I
;D ERROUT(BMXERR,A)
;B ;ERROR in BMXSQL
Q
;
ERROUT(BMXERR,I) ;EP
;---> Save next line for Error Code File if ever used.
;---> If necessary, use I>1 to avoid overwriting valid data.
D ERRTACK(I)
Q
;
ERRTRAP ;
;
K ^BMXTEMP($J)
S ^BMXTEMP($J,0)="T00030M_ERROR"_$C(30)
S BMXZE=$$EC^%ZOSV
S BMXZE=$TR(BMXZE,"^","~")
S ^BMXTEMP($J,1)=BMXZE_$C(30)
S ^BMXTEMP($J,2)=$C(31)
Q
BMXSQL ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
+4 QUIT
+5 ;
FLDNDX(BMXGBL,BMXFL,BMXFLD) ;
+1 ;Returns index name and set code for all indexes on field
+2 ;on field BMXFLD in file BMXFL
+3 SET BMX31=$CHAR(31)_$CHAR(31)
+4 KILL ^BMXTMP($JOB),^BMXTEMP($JOB)
+5 SET BMXGBL="^BMXTEMP("_$JOB_")"
+6 IF +BMXFL'=BMXFL
Begin DoDot:1
+7 SET BMXFL=$TRANSLATE(BMXFL,"_"," ")
+8 IF '$DATA(^DIC("B",BMXFL))
SET BMXFL=""
QUIT
+9 SET BMXFL=$ORDER(^DIC("B",BMXFL,0))
End DoDot:1
+10 IF '$GET(BMXFL)
DO ERROUT("File number not provided.",1)
QUIT
+11 ;
+12 ;Check for field name
+13 IF +BMXFLD'=BMXFLD
Begin DoDot:1
+14 SET BMXFLD=$TRANSLATE(BMXFLD,"_"," ")
+15 IF '$DATA(^DD(BMXFL,"B",BMXFLD))
SET BMXFLD=""
QUIT
+16 SET BMXFLD=$ORDER(^DD(BMXFL,"B",BMXFLD,0))
End DoDot:1
+17 IF '$GET(BMXFLD)
DO ERROUT("Field not provided",1)
QUIT
+18 ;
+19 ;Set up Column names
+20 SET ^BMXTEMP($JOB,0)="T"_$$NUMCHAR(30)_"INDEX^T"_$$NUMCHAR(200)_"CODE"_$CHAR(30)
+21 ;
+22 ;Write field data to BMXTEMP
+23 SET BMXI=0
SET I=0
+24 NEW BMXNAM,BMXCOD,BMXNOD,BMXTYP
+25 FOR
SET BMXI=$ORDER(^DD(BMXFL,BMXFLD,1,BMXI))
IF '+BMXI
QUIT
IF $DATA(BMXERR)
QUIT
Begin DoDot:1
+26 SET I=I+1
+27 SET BMXNOD=$GET(^DD(BMXFL,BMXFLD,1,BMXI,0))
+28 SET BMXNAM=$PIECE(BMXNOD,U,2)
+29 SET BMXTYP=$PIECE(BMXNOD,U,3)
+30 IF BMXTYP=""
SET BMXTYP="REGULAR"
+31 SET BMXCOD=$GET(^DD(BMXFL,BMXFLD,1,BMXI,1))
+32 SET BMXCOD=$TRANSLATE(BMXCOD,"^","~")
+33 SET ^BMXTEMP($JOB,I)=BMXNAM_U_BMXTYP_U_BMXCOD_$CHAR(30)
End DoDot:1
+34 QUIT
+35 ;
TLIST(BMXGBL,BMXFROM,BMXTO) ;
+1 ;Returns list of Fileman files to which user has READ access
+2 ;TODO: Pass in type of access (RD,DL,WR) in BMXPAR
+3 ;
+4 NEW A,F,BMXF,BMXFLD,D0,BMXU,I,BMXCNT,BMXMFL,BMXRD,BMXMAX
+5 SET U="^"
+6 IF $GET(BMXFROM)="RD"
SET BMXFROM=""
+7 KILL ^BMXTMP($JOB),^BMXTEMP($JOB)
+8 SET BMXGBL="^BMXTEMP("_$JOB_")"
+9 SET BMXF=1
+10 SET BMXF("FILE")=1
+11 SET BMXFLD("FILE")="1^.01"
+12 ;ADDED
SET BMXFLD("NUMBER")="1^.001"
+13 SET BMXFLDN=$PIECE(BMXFLD("FILE"),"^",2)
+14 SET BMXFLDN(1,BMXFLDN)="FILE"
+15 ;ADDED
SET BMXFLDN=$PIECE(BMXFLD("NUMBER"),"^",2)
+16 ;ADDED
SET BMXFLDN(1,BMXFLDN)="NUMBER"
+17 ;CHANGED FROM 1 TO 2
SET BMXFLDO=2
+18 SET BMXFLDO(0)="1^.01"
+19 SET BMXFLDOX(1,.01,"E")=0
+20 ;ADDED
SET BMXFLDO(1)="1^.001"
+21 ;ADDED
SET BMXFLDOX(1,.001,"E")=1
+22 SET BMXFNX(1)="FILE"
+23 SET BMXFO(1)="1"
+24 SET BMXU=$GET(DUZ(0))
+25 SET BMXRD=$CHAR(30)
+26 SET ^BMXTEMP($JOB,0)="T00030FILE^N00010NUMBER"_BMXRD
+27 SET BMXSET="S I=I+1,^BMXTEMP($J,I)=$P($G(^DIC(D0,0)),U)_U_D0_BMXRD,BMXCNT=BMXCNT+1"
+28 SET D0=0
SET I=0
SET BMXCNT=0
SET BMXMAX=2000
+29 SET BMXFROM=$GET(BMXFROM)
SET BMXTO=$GET(BMXTO)
+30 ;BMXFROM is a filenumber
IF +BMXFROM=BMXFROM
Begin DoDot:1
+31 SET F=(+BMXFROM-1)
SET T=+BMXTO
+32 IF BMXTO<BMXFROM
SET BMXTO=BMXFROM+1
+33 SET D0=F
FOR
SET D0=$ORDER(^DIC(D0))
IF '+D0
QUIT
IF D0>T
QUIT
IF BMXCNT>BMXMAX
QUIT
IF $DATA(^DD(D0))
DO TLIST1
End DoDot:1
+34 ;F is a filename or is null
IF +BMXFROM'=BMXFROM
Begin DoDot:1
+35 SET F=""
SET T="zzzzzzz"
+36 IF $GET(BMXFROM)]""
SET F=$ORDER(^DIC("B",BMXFROM),-1)
+37 IF $GET(BMXTO)]""
SET T=BMXTO
+38 FOR
SET F=$ORDER(^DIC("B",F))
IF F=""
QUIT
IF F]T
QUIT
IF BMXCNT>BMXMAX
QUIT
Begin DoDot:2
+39 SET D0=0
FOR
SET D0=$ORDER(^DIC("B",F,D0))
IF '+D0
QUIT
DO TLIST1
End DoDot:2
End DoDot:1
+40 ;
+41 SET I=I+1
SET ^BMXTEMP($JOB,I)=$CHAR(31)
+42 QUIT
+43 ;
TLIST1 ;
+1 IF BMXU="@"
XECUTE BMXSET
QUIT
+2 IF $DATA(^DIC(D0,0))'=11
QUIT
+3 SET A=$GET(^DIC(D0,0,"RD"))
+4 IF $DATA(^VA(200,DUZ,"FOF",D0,0))
Begin DoDot:1
+5 ;I $P(^(0),U,5)="1" X BMXSET Q
+6 IF $PIECE(^VA(200,DUZ,"FOF",D0,0),U,5)="1"
XECUTE BMXSET
QUIT
End DoDot:1
QUIT
+7 FOR J=1:1:$LENGTH(A)
IF DUZ(0)[$EXTRACT(A,J)
XECUTE BMXSET
+8 QUIT
+9 ;
SQLCOL(BMXGBL,BMXSQL) ;EP
+1 DO INTSQL(.BMXGBL,.BMXSQL,1)
+2 QUIT
+3 ;
SQLD(BMXGBL,BMXSQL) ;EP Serenji Debug Entrypoint
+1 ;D DEBUG^%Serenji("SQLD^BMXSQL(.BMXGBL,.BMXSQL)")
+2 QUIT
+3 ;
SQL(BMXGBL,BMXSQL) ;EP
+1 DO INTSQL(.BMXGBL,.BMXSQL,0)
+2 QUIT
+3 ;
INTSQL(BMXGBL,BMXSQL,BMXCOL) ;EP
+1 ;
+2 ;SQL Top Wait for debug break
+3 ;D
+4 ;. F J=1:1:10 S K=$H H 1
+5 ;. Q
+6 ;
+7 SET X="ERRTRAP^BMXSQL"
SET @^%ZOSF("TRAP")
+8 IF $GET(BMXSQL)=""
SET BMXSQL=""
Begin DoDot:1
+9 NEW C
SET C=0
FOR
SET C=$ORDER(BMXSQL(C))
IF '+C
QUIT
Begin DoDot:2
+10 SET BMXSQL=BMXSQL_BMXSQL(C)
End DoDot:2
End DoDot:1
+11 ;
+12 IF BMXSQL["call SHAPE"
SET BMXSQL="SELECT JUNKNAME, MULTCOLOR FROM JUNKMULT"
+13 ; Global-scope variables
+14 KILL BMXTK
+15 NEW BMXF,BMXTK,T,BMXFLD,BMXTMP,BMXM,BMXXMAX,BMXFLDN,BMXV
+16 NEW BMXX,BMXFG,BMXFF,BMXSCR,BMXPFP
+17 NEW BMXERR,BMXFLDO,BMXFLDOX,BMXFJ,BMXFO,BMXFNX
+18 NEW BMXMFL,BMXFLDA
+19 DO ^XBKVAR
+20 SET U="^"
+21 IF $DATA(^%ZOSF("MAXSIZ"))
SET X=640
XECUTE ^%ZOSF("MAXSIZ")
+22 KILL ^BMXTMP($JOB),^BMXTEMP($JOB),^BMXTMPD($JOB)
+23 SET BMXGBL="^BMXTEMP("_$JOB_")"
+24 ;Remove CR and LF from BMXSQL
+25 SET BMXSQL=$TRANSLATE(BMXSQL,$CHAR(13)," ")
+26 SET BMXSQL=$TRANSLATE(BMXSQL,$CHAR(10)," ")
+27 SET BMXSQL=$TRANSLATE(BMXSQL,$CHAR(9)," ")
+28 SET BMXSQL=$TRANSLATE(BMXSQL,$CHAR(34),"")
+29 DO PARSE^BMXPRS(BMXSQL)
+30 ;Default Maximum records to return.
SET BMXXMAX=1000000
+31 DO KW^BMXSQL1(.BMXTK)
+32 IF $DATA(BMXERR)
QUIT
+33 ;
+34 ;Get file names into BMXF("NAME")="NUMBER"
+35 ;Get file numbers into BMXFNX(NUMBER)="NAME"
+36 ; Files are ordered in BMXFO(order)="NUMBER"
+37 ;
FROM SET T=$GET(BMXTK("FROM"))
+1 IF '+T
SET BMXERR="'FROM' CLAUSE NOT FOUND"
DO ERROR
QUIT
+2 SET BMXF=0
+3 FOR
SET T=$ORDER(BMXTK(T))
IF '+T
QUIT
IF T=$GET(BMXTK("WHERE"))
QUIT
IF T=$GET(BMXTK("ORDER BY"))
QUIT
IF T=$GET(BMXTK("GROUP BY"))
QUIT
Begin DoDot:1
+4 IF BMXTK(T)=","
QUIT
+5 NEW BMXFNT
+6 IF BMXTK(T)["'"
SET BMXTK(T)=$PIECE(BMXTK(T),"'",2)
+7 SET BMXTK(T)=$TRANSLATE(BMXTK(T),"_"," ")
+8 IF '(BMXTK(T)?.N)
IF '$DATA(^DIC("B",BMXTK(T)))
SET BMXERR="FILE NOT FOUND"
DO ERROR
QUIT
+9 SET BMXF=BMXF+1
+10 IF BMXTK(T)?.N
SET BMXFNT=BMXTK(T)
+11 IF '$TEST
SET BMXFNT=$ORDER(^DIC("B",BMXTK(T),0))
+12 SET BMXMFL(BMXFNT,"GLOC")=^DIC(BMXFNT,0,"GL")
+13 DO F1(BMXF,BMXTK(T),BMXFNT)
+14 IF '+BMXF(BMXTK(T))
SET BMXERR="FILE NUMBER NOT FOUND"
DO ERROR
QUIT
+15 ;Test alias
Begin DoDot:2
+16 IF '+$ORDER(BMXTK(T))
QUIT
+17 NEW V
+18 SET V=T+1
+19 IF $GET(BMXTK(V))=","
QUIT
+20 IF V=$GET(BMXTK("WHERE"))
QUIT
+21 IF V=$GET(BMXTK("ORDER BY"))
QUIT
+22 IF V=$GET(BMXTK("GROUP BY"))
QUIT
+23 SET BMXTK(T,"ALIAS")=BMXTK(V)
+24 KILL BMXTK(V)
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
IF $DATA(BMXERR)
QUIT
+27 ;
+28 DO SELECT^BMXSQL5
+29 IF $DATA(BMXERR)
GOTO END
+30 ;Remove commas from BMXTK
DO POST2^BMXPRS
+31 DO KW^BMXSQL1(.BMXTK)
+32 ;
+33 DO WHERE^BMXSQL7
+34 ;
+35 ;Find the first WHERE field that has an index
+36 IF $DATA(BMXERR)
GOTO END
+37 ;
+38 DO INDEX(.BMXFF,.BMXX,.BMXTMP)
+39 ;
+40 IF BMXTMP
SET BMXX=BMXTMP
+41 ;
+42 ;Set up screen logic for where fields
+43 DO SCREEN^BMXSQL1
+44 DO SETX^BMXSQL2(.BMXX,.BMXFG,.BMXSCR)
+45 ;
+46 ;
EXEC ;Execute enumerator and screen code to call Output routine
+1 ;
+2 NEW BMXOUT,J,BMXC
+3 SET BMXOUT=0
+4 ;Debug lines (retain):
+5 ;K ^HW("BMXX") S J=0 F S J=$O(BMXX(J)) Q:'+J S ^HW("BMXX",J)=BMXX(J)
+6 ;K ^HW("BMXSCR") S ^HW("BMXSCR")=$G(BMXSCR) S J=0 F S J=$O(BMXSCR(J)) Q:'+J S ^HW("BMXSCR",J)=BMXSCR(J)
+7 ;Test for SHOWPLAN
+8 IF $GET(BMXTK("SHOWPLAN"))="TRUE"
DO WPLAN
QUIT
+9 SET BMXM=0
+10 IF 'BMXCOL
SET J=0
FOR
SET J=$ORDER(BMXX(J))
IF '+J
QUIT
Begin DoDot:1
+11 XECUTE BMXX(J)
End DoDot:1
IF BMXM>BMXXMAX
QUIT
+12 ;
+13 DO WRITE^BMXSQL6
+14 ;
END QUIT
+1 ;
+2 ;
F1(BMXC,BMXNAM,BMXNUM) ;EP
+1 SET BMXF(BMXNAM)=BMXNUM
+2 SET BMXFNX(BMXNUM)=BMXNAM
+3 SET BMXFO(BMXC)=BMXF(BMXNAM)
+4 QUIT
+5 ;
OUT ;Set result in ^BMXTMP
+1 SET BMXOUT=BMXOUT+1
+2 SET ^BMXTMP($JOB,"O",D0)=""
+3 SET ^BMXTMP($JOB,BMXOUT)=D0
+4 SET BMXM=BMXM+1
+5 QUIT
+6 ;
WPLAN ;Write execution plan
+1 ;Set up Column Names
+2 NEW BMXLEN,BMXTYP,BMXT,J,BMXSCRT,BMXXT
+3 SET I=1
+4 FOR BMXT="VARIABLE^","VALUE"_$CHAR(30)
Begin DoDot:1
+5 SET ^BMXTEMP($JOB,I)=BMXT
SET BMXLEN(I)=15
SET BMXTYP(I)="T"
+6 SET I=I+1
End DoDot:1
+7 SET J=0
+8 IF $DATA(BMXX)
FOR
SET J=$ORDER(BMXX(J))
IF '+J
QUIT
Begin DoDot:1
+9 SET ^BMXTEMP($JOB,I)="INDEX("_J_")^"
+10 SET I=I+1
+11 SET BMXXT(J)=BMXX(J)
+12 SET BMXXT(J)=$PIECE(BMXXT(J)," X BMXSCR")
+13 SET ^BMXTEMP($JOB,I)=$TRANSLATE(BMXXT(J),"^","~")_$CHAR(30)
+14 IF $LENGTH(^BMXTEMP($JOB,I))>BMXLEN(2)
SET BMXLEN(2)=$LENGTH(^BMXTEMP($JOB,I))
+15 SET I=I+1
End DoDot:1
+16 SET ^BMXTEMP($JOB,I)="SCREEN^"
+17 SET I=I+1
+18 SET BMXSCRT=$GET(BMXSCR)
+19 SET BMXSCRT=$PIECE(BMXSCRT,"D:'$D(^BMXTMP")
+20 SET ^BMXTEMP($JOB,I)=$TRANSLATE(BMXSCRT,"^","~")_$CHAR(30)
+21 IF $LENGTH(^BMXTEMP($JOB,I))>BMXLEN(2)
SET BMXLEN(2)=$LENGTH(^BMXTEMP($JOB,I))
+22 SET I=I+1
+23 SET J=0
+24 IF $DATA(BMXSCR("C"))
FOR
SET J=$ORDER(BMXSCR("C",J))
IF '+J
QUIT
Begin DoDot:1
+25 SET ^BMXTEMP($JOB,I)="SCREEN("_J_")^"
+26 SET I=I+1
+27 SET ^BMXTEMP($JOB,I)=$TRANSLATE(BMXSCR("C",J),"^","~")_$CHAR(30)
+28 IF $LENGTH(^BMXTEMP($JOB,I))>BMXLEN(2)
SET BMXLEN(2)=$LENGTH(^BMXTEMP($JOB,I))
+29 SET I=I+1
End DoDot:1
+30 DO COLTYPE
+31 SET I=I+1
+32 DO ERRTACK(I)
+33 QUIT
+34 ;
+35 ;
COLTYPE ;EP - Append column types and widths to output global
+1 ;REQUIRES - BMXLEN(),BMXTYP(),^BMXTEMP
+2 ;IHS/SET/HMW 4-22-2004 Modified to use new schema string
+3 ;
+4 ;"@@@meta@@@BMXIEN|FILE #|DA STRING"
+5 ;
+6 NEW C
+7 SET C=0
+8 FOR
SET C=$ORDER(BMXLEN(C))
IF 'C
QUIT
Begin DoDot:1
+9 IF BMXLEN(C)>99999
SET BMXLEN(C)=99999
+10 ;Default column length
IF BMXLEN(C)=0
SET BMXLEN(C)=50
+11 SET ^BMXTEMP($JOB,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($JOB,C)
End DoDot:1
+12 QUIT
+13 ;
+14 ;S ^BXTEMP($J,0)="@@@meta@@@BMXIEN|"_BMXF_"|" ;Last |-piece will be DA string
+15 ;N C
+16 ;S C=0
+17 ;F S C=$O(BMXLEN(C)) Q:'C D
+18 ;. I BMXLEN(C)>99999 S BMXLEN(C)=99999
+19 ;. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length
+20 ;. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C)
+21 ;Q
+22 ;
ERRTACK(I) ;EP
+1 ;
+2 SET ^BMXTEMP($JOB,I)=$CHAR(31)
+3 IF $DATA(BMXERR)
SET ^BMXTEMP($JOB,I)=^BMXTEMP($JOB,I)_BMXERR
+4 QUIT
+5 ;
NUMCHAR(BMXN) ;EP
+1 ;---> Returns Field Length left-padded with 0
+2 ;
+3 NEW BMXC
+4 SET BMXC="00000"_BMXN
+5 QUIT $EXTRACT(BMXC,$LENGTH(BMXC)-4,$LENGTH(BMXC))
+6 ;
+7 ;
INDEX(BMXFF,BMXRET,BMXXCNT) ;
+1 ;Returns executable enumerator on first where field with an index
+2 ;or "" if no indexed where field
+3 ;IN: BMXFF()
+4 ;OUT: BMXRET()
+5 ; BMXXCNT - size of BMXRET array
+6 ;
+7 NEW F,BMXNOD,BMXFNUM,BMXFLDNM,BMXHIT,BMXREF,BMXRNAM,BMXOP,Q,BMXGL
+8 NEW BMXTMP,BMXTMPV,BMXTMPI,BMXTMPL,BMXTMPN,BMXV,BMXRNOD,BMXTMPP
+9 SET BMXXCNT=0
+10 SET Q=$CHAR(34)
+11 IF 'BMXFF
QUIT
+12 SET F=0
SET BMXHIT=0
+13 ;
+14 ;--->Search BMXFF for special case WHERE clause 1 = "0"
+15 ; reset BMXX(1) to return no records
+16 FOR F=1:1:BMXFF
SET BMXNOD=BMXFF(F)
Begin DoDot:1
+17 IF ($PIECE(BMXFF(F),"^",2,4)="1^=^0")!($PIECE(BMXFF(F),"^",2,4)="0^=^1")
SET BMXRET(1)="Q "
SET BMXHIT=1
SET BMXXCNT=1
+18 QUIT
End DoDot:1
IF $DATA(BMXERR)
QUIT
IF BMXHIT
QUIT
+19 IF BMXHIT
QUIT
+20 ;
+21 ;Organize the first level into AND- and OR-parts
+22 NEW BMXR1,BMXR2,BMXE,BMXR3,BMXRNAM
+23 NEW BMXSTOP,BMXOR
+24 DO PLEVEL^BMXSQL3(.BMXFF,.BMXR1,.BMXR2)
+25 ;
+26 NEW BMXPFF
SET BMXPFF=0
+27 SET BMXR3=0
+28 ;Look for an AND-part with only one element.
+29 ; If found, build an iterator on it and quit
+30 FOR J=1:1:$LENGTH(BMXR2,"&")
Begin DoDot:1
+31 SET BMXE=$PIECE(BMXR2,"&",J)
+32 IF +BMXE=BMXE
IF BMXR1(BMXE,"ELEMENTS")=1
Begin DoDot:2
+33 ;Test index for element
+34 ;I'm not sure why this quit was here
FOR K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END")
IF "(^)"'[BMXFF(K)
Begin DoDot:3
+35 IF $DATA(BMXFF(K,"JOIN"))
QUIT
+36 SET BMXPFP=K
SET BMXPFF=0
+37 DO XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
+38 IF BMXR3
SET BMXHIT=1
SET BMXFF(K,"INDEXED")=1
End DoDot:3
QUIT
End DoDot:2
+39 IF 'BMXHIT
QUIT
+40 ;Build iterator and quit
+41 DO BLDIT^BMXSQL3(.BMXFF,K,.BMXRNAM,.BMXOR,.BMXPFP)
+42 SET BMXXCNT=1
+43 SET BMXRET(BMXXCNT)=BMXOR
+44 QUIT
End DoDot:1
IF BMXHIT
QUIT
+45 IF BMXHIT
QUIT
+46 ;
+47 ;None of the single-element AND parts has a good index or
+48 ; there are no single-element AND parts
+49 ;If there are no OR-parts, then there are no good indexes so quit
+50 IF $LENGTH(BMXR2,"!")=1
QUIT
+51 ;
+52 ;Test each OR-part for a good index.
+53 ;If an OR-part is multi-element or
+54 ;if one OR-part doesn't have an index
+55 ;then set up to do a table scan and quit
+56 SET BMXSTOP=0
+57 FOR J=1:1:$LENGTH(BMXR2,"!")
Begin DoDot:1
+58 SET BMXE=$PIECE(BMXR2,"!",J)
+59 IF +BMXE=BMXE
Begin DoDot:2
+60 ;Multiple elements
IF BMXR1(BMXE,"ELEMENTS")'=1
SET BMXSTOP=1
QUIT
+61 ;Test index elements
+62 FOR K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END")
IF "(^)"'[BMXFF(K)
Begin DoDot:3
+63 SET BMXPFP=K
SET BMXPFF=0
+64 DO XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP)
+65 IF 'BMXR3
SET BMXSTOP=1
QUIT
+66 SET BMXFF(K,"INDEXED")=1
+67 SET BMXR1(BMXE,"XREF")=BMXRNAM
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
IF BMXSTOP
QUIT
+68 ;
+69 ;Build iterator and quit
+70 ;One of the elements had no index
IF BMXSTOP
Begin DoDot:1
+71 SET J=0
FOR
SET J=$ORDER(BMXFF(J))
IF '+J
QUIT
KILL BMXFF(J,"INDEXED")
End DoDot:1
QUIT
+72 SET BMXXCNT=0
+73 FOR J=1:1:$LENGTH(BMXR2,"!")
Begin DoDot:1
+74 SET BMXE=$PIECE(BMXR2,"!",J)
+75 IF +BMXE=BMXE
IF BMXR1(BMXE,"ELEMENTS")=1
Begin DoDot:2
+76 FOR K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END")
IF "(^)"'[BMXFF(K)
Begin DoDot:3
+77 DO BLDIT^BMXSQL3(.BMXFF,K,BMXR1(BMXE,"XREF"),.BMXOR,.BMXPFP)
+78 SET BMXXCNT=BMXXCNT+1
+79 SET BMXRET(BMXXCNT)=BMXOR
End DoDot:3
QUIT
End DoDot:2
+80 QUIT
End DoDot:1
+81 QUIT
+82 ;
+83 ;
+84 ;
ERROR ;EP - Error processing
+1 ;W !,BMXERR
+2 ;N A
+3 ;S A=0
+4 ;I $D(I) S A=I
+5 ;D ERROUT(BMXERR,A)
+6 ;B ;ERROR in BMXSQL
+7 QUIT
+8 ;
ERROUT(BMXERR,I) ;EP
+1 ;---> Save next line for Error Code File if ever used.
+2 ;---> If necessary, use I>1 to avoid overwriting valid data.
+3 DO ERRTACK(I)
+4 QUIT
+5 ;
ERRTRAP ;
+1 ;
+2 KILL ^BMXTEMP($JOB)
+3 SET ^BMXTEMP($JOB,0)="T00030M_ERROR"_$CHAR(30)
+4 SET BMXZE=$$EC^%ZOSV
+5 SET BMXZE=$TRANSLATE(BMXZE,"^","~")
+6 SET ^BMXTEMP($JOB,1)=BMXZE_$CHAR(30)
+7 SET ^BMXTEMP($JOB,2)=$CHAR(31)
+8 QUIT
