BMXSQL7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;4.0;BMX;;JUN 28, 2010
;
;
CHKCR(BMXFNUM,BMXFLDNU,BMXRET) ;Returns cross reference to iterate on for related file
N BMXREF,BMXHIT,BMXRNOD,BMXTMP,BMXTMPV,BMXTMPI,BMXTMPP,BMXPFFN,BMXPFF,Q
N BMXHIT,BMXREF,BMXGL,BMXNOD,BMXRNAM,BMXTMPL,BMXTMPN,BMXTST
;
S BMXNOD=^DD(BMXFNUM,BMXFLDNU,0)
S BMXGL=^DIC(BMXFNUM,0,"GL") ;Subfile global
S BMXREF=0,BMXHIT=0,Q=$C(34),BMXRET=""
F S BMXREF=$O(^DD(BMXFNUM,BMXFLDNU,1,BMXREF)) Q:'+BMXREF D Q:BMXHIT
. Q:'$D(^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0))
. S BMXRNOD=^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0)
. Q:$P(BMXRNOD,U,3)]""
. S BMXRNAM=$P(BMXRNOD,U,2)
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_")"
. S BMXTST=$P(BMXTMP,")")_",IEN0,"
. Q:'$D(@BMXTMP)
. S BMXTMPV=0,BMXTMPV=$O(@BMXTMP@(BMXTMPV))
. Q:BMXTMPV=""
. S BMXTMP=BMXGL_Q_BMXRNAM_Q_","_Q_BMXTMPV_Q_")"
. S BMXTMPI=0,BMXTMPI=$O(@BMXTMP@(BMXTMPI))
. S BMXTMP=$S(BMXGL[",":$P(BMXGL,",")_")",1:$P(BMXGL,"("))
. Q:'$D(@BMXTMP@(BMXTMPI))
. S BMXTMPL=$P(BMXNOD,U,4)
. S BMXTMPP=$P(BMXTMPL,";",2)
. S BMXTMPL=$P(BMXTMPL,";")
. Q:BMXTMPL=""
. S BMXTMP=BMXGL_BMXTMPI_")"
. Q:'$D(@BMXTMP@(BMXTMPL))
. S BMXTMPN=@BMXTMP@(BMXTMPL)
. S BMXTMPP=$P(BMXTMPN,"^",BMXTMPP)
. I BMXTMPP=BMXTMPV S BMXRET=BMXTST,BMXHIT=1
Q BMXHIT
;
;
WHERE ;EP - WHERE-clause processing
;
;Set up the defualt iterator in BMXX(1) to scan the entire file.
;For now, just use first file in the FROM group
;Later, pick the smallest file if more than one file
;
;Set up BMXFF array for each expression element
; BMXFF(n)=FILENAME^FIELDNAME^OPERATOR^VALUE^FILENUMBER^FIELDNUMBER
; ^FILE GLOBAL^FIELD DATA LOCATION
; BMXFF(n,0)=Field descriptor ^DD(FILE,FIELD,0)
;
N BMXGL,BMXOP,BMXTYP,BMXV,BMXV1,BMXV2,BMXFILE,BMXTMP
N BMXINTNL,BMXTMPLT
N BMXIEN
S BMXGL=^DIC(BMXFO(1),0,"GL")
S BMXX=1
S BMXX(1)="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX "
S BMXTMP=BMXGL
I BMXTMP["," S BMXTMP=$TR(BMXTMP,",",")")
E S BMXTMP=$P(BMXTMP,"(",1)
I $D(@BMXTMP@("B")) D
. S BMXX(1)="S BMXTMP=0 F S BMXTMP=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP)) Q:BMXTMP="""" S D0=0 F S D0=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP,D0)) Q:'+D0 Q:BMXM>BMXXMAX "
;
;--->BMXFF array:
;
S T=$G(BMXTK("WHERE"))
S BMXFF=0,C=0
Q:'+T
F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR)
. ;Get the file of the field
. I "AND^OR^(^)"[BMXTK(T) D Q
. . S C=C+1
. . S BMXFF(C)=BMXTK(T)
. . S BMXFF=C
. S BMXTK(T)=$TR(BMXTK(T),"_"," ")
. S BMXTK(T)=$TR(BMXTK(T),"'","")
. S BMXINTNL=0
. S BMXTMPLT=0
. S BMXIEN=0
. I BMXTK(T)["INTERNAL[" S BMXINTNL=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1)
. I BMXTK(T)["TEMPLATE[" S BMXTMPLT=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1),BMXIEN=1
. I BMXTK(T)["BMXIEN" S BMXIEN=1
. S BMXFILE=$$FLDFILE^BMXSQL2(BMXTK(T))
. Q:$D(BMXERR)
. S C=C+1
. S BMXFF=C ;This is a count of the where fields
. I BMXFILE]"" D
. . S $P(BMXFF(C),U,1)=$P(BMXFILE,U,1) ;FILENAME
. . S $P(BMXFF(C),U,2)=$P(BMXFILE,U,2) ;FIELDNAME
. . S $P(BMXFF(C),U,5)=$P(BMXFILE,U,3) ;FILENUMBER
. . S $P(BMXFF(C),U,6)=$P(BMXFILE,U,4) ;FIELDNUMBER
. . I $P(BMXFILE,U,3),$D(^DIC($P(BMXFILE,U,3),0,"GL")) S $P(BMXFF(C),U,7)=^DIC($P(BMXFILE,U,3),0,"GL")
. . I BMXIEN S BMXFF(C,0)="IEN",BMXFF(C,"IEN")=1,BMXFF(C,"TYPE")="IEN"
. . E S BMXFF(C,0)=$S(+$P(BMXFILE,U,3):^DD($P(BMXFILE,U,3),$P(BMXFILE,U,4),0),1:"")
. . I BMXINTNL S BMXFF(C,"INTERNAL")=1
. ;
. ;If BMXFF(C) is a pointer, traverse pointer chain to retrieve type
. I $P(BMXFF(C,0),U,2)["P" D
. . ;B ;WHERE Pointer Type
. . N BMXFILN,BMXFLDN,BMXDD
. . S BMXDD=BMXFF(C,0)
. . F Q:$P(BMXDD,U,2)'["P" D:$P(BMXDD,U,2)["P"
. . . S BMXFILN=$P(BMXDD,U,2)
. . . S BMXFILN=+$P(BMXFILN,"P",2)
. . . S BMXDD=^DD(BMXFILN,".01",0)
. . S BMXFF(C,"TYPE")=$S($P(BMXDD,U,2)["D":"DATE",$P(BMXDD,U,2)["S":"SET",1:"OTHER")
. . I BMXFF(C,"TYPE")="SET" S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXDD,U,3)
. ;B ;WHERE Set Type
. I ($P(BMXFF(C,0),U,2)["S")!($P($G(BMXFF(C,"TYPE")),U)="SET") D ;Set
. . N BMXSET,BMXSETP
. . I $P(BMXFF(C,0),U,2)["S" D
. . . S BMXFF(C,"TYPE")="SET"
. . . S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXFF(C,0),U,3)
. . S BMXSET=$P(BMXFF(C,"TYPE"),U,2)
. . F J=1:1:$L(BMXSET,";") D
. . . S BMXSETP=$P(BMXSET,";",J)
. . . Q:BMXSETP=""
. . . S BMXFF(C,"SET",$P(BMXSETP,":",2))=$P(BMXSETP,":")
. ;
. ;Set up comparisons based on operators
. S T=T+1
. S BMXOP=BMXTK(T)
. I BMXTMPLT S BMXOP="="
. I "^<^>^=^[^<>^>=^<=^LIKE"[BMXOP D Q
. . S $P(BMXFF(C),U,3)=BMXTK(T)
. . ;Get the comparison value
. . S T=T+1
. . S BMXTMP=BMXTK(T)
. . S BMXTMP=$TR(BMXTMP,"'","")
. . I BMXOP="LIKE" S BMXTMP=$P(BMXTMP,"%"),$P(BMXFF(C),U,4)=BMXTMP Q
. . I BMXTMPLT D TMPLATE Q
. . I BMXTMP="*" S T=T+1,BMXTMP=BMXTK(T) D OTM Q
. . I BMXTMP[".",BMXTK(T)'["'" D ;This is a join ;TODO: Extended pointers
. . . ;Setting BMXFJ("JOIN"
. . . S BMXTMP=BMXTK(T)
. . . I $D(BMXF($P(BMXTMP,"."))),BMXF($P(BMXTMP,"."))=BMXFO(1) D Q
. . . . S BMXTMP=BMXTK(T-2)
. . . . D OTM
. . . N BMXJN
. . . S BMXFF(C,"JOIN")="Pointer chain"
. . . S BMXJN=+$P($P(BMXFF(C,0),U,2),"P",2)
. . . S BMXFJ("JOIN",+$P($P(BMXFF(C,0),U,2),"P",2))=C
. . . S:+$P($P(BMXFF(C,0),U,2),"P",2)=2 BMXFJ("JOIN",9000001)=C ;IHS Only -- auto join PATIENT to VA PATIENT
. . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . I BMXTMP]"" S X=BMXTMP,%DT="T" D ^%DT S BMXTMP=Y
. . I $P($G(BMXFF(C,"TYPE")),U)="SET" D
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . Q:BMXTMP=""
. . . I $G(BMXFF(C,"SET",BMXTMP))="" S BMXTMP="ZZZZZZ" Q
. . . S BMXTMP=$G(BMXFF(C,"SET",BMXTMP))
. . S $P(BMXFF(C),U,4)=BMXTMP
. . Q
. I BMXOP="BETWEEN" D
. . S $P(BMXFF(C),U,3)="BETWEEN"
. . ;Get the comparison value
. . S T=T+1
. . S BMXV1=BMXTK(T)
. . S:BMXV1["'" BMXV1=$P(BMXV1,"'",2)
. . S T=T+1
. . I BMXTK(T)'="AND" S BMXERR="'BETWEEN' VALUES NOT SPECIFIED" D ERROR Q
. . S T=T+1
. . S BMXV2=BMXTK(T)
. . S:BMXV2["'" BMXV2=$P(BMXV2,"'",2)
. . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date
. . . Q:$D(BMXFF(C,"INTERNAL"))
. . . S X=BMXV1,%DT="T" D ^%DT S BMXV1=Y
. . . S X=BMXV2,%DT="T" D ^%DT S BMXV2=Y
. . I BMXV1>BMXV2 S BMXTMP=BMXV1,BMXV1=BMXV2,BMXV2=BMXTMP
. . S $P(BMXFF(C),U,4)=BMXV1_"~"_BMXV2
. . Q
. I $P(BMXFF(C),U,3)="" S BMXERR="INVALID OPERATOR" D ERROR Q
. I $D(BMXTK(T+1)),BMXTK(T+1)["[INDEX:" D
. . S T=T+1
. . N BMXIND
. . S BMXIND=$P(BMXTK(T),"INDEX:",2)
. . S:BMXIND["]" BMXIND=$P(BMXIND,"]")
. . S:BMXIND["'" BMXIND=$P(BMXIND,"'",2)
. . S BMXFF("INDEX")=BMXIND
. Q
;
Q:$D(BMXERR)
D JOIN^BMXSQL4
Q
;
TMPLATE ;
N BMXTNUM,BMXTNOD
I BMXTMP["[" S BMXTMP=$P(BMXTMP,"[",2),BMXTMP=$P(BMXTMP,"]")
S BMXTMP=$TR(BMXTMP,"_"," ")
;Test template validity
I '$D(^DIBT("B",BMXTMP)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q
S BMXTNUM=$O(^DIBT("B",BMXTMP,0))
I '$D(^DIBT(BMXTNUM,0)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q
S BMXTNOD=^DIBT(BMXTNUM,0)
I $P(BMXTNOD,U,4)'=$P(BMXFF(C),U,5) S BMXERR="TEMPLATE DOES NOT MATCH FILE" D ERROR Q
I '$D(^DIBT(BMXTNUM,1)) S BMXERR="TEMPLATE HAS NO ENTRIES" D ERROR Q
S BMXFF(C,0)="IEN",BMXFF(C,"IEN")="TEMPLATE",BMXFF(C,"TYPE")="IEN"
S $P(BMXFF(C),U,4)=BMXTMP
;
Q
;
OTM ;One-To-Many
N BMXUPFN,BMXSUBFN,BMXA,BMXB,BMXSBFLD,BMXFNAM
I BMXTMP["INTERNAL[" S BMXTMP=$P(BMXTMP,"INTERNAL[",2),BMXTMP=$P(BMXTMP,"]")
S BMXUPFN=BMXFO(1)
S BMXA=$TR($P(BMXTMP,"."),"_"," ")
S BMXB=$TR($P(BMXTMP,".",2),"_"," ")
S BMXFNAM=BMXB ;Required by SETMFL. Won't work if filename BMXB [ "."
;Get the subfile
I '$D(BMXF(BMXA)) S BMXERR="Related File Not Found" Q
S BMXSUBFN=BMXF(BMXA)
I '$D(^DD(BMXSUBFN,0)) S BMXERR="Related file not found" Q
;Get the field that points to the main file
I '$D(^DD(BMXSUBFN,"B",BMXB)) S BMXERR="Related field not found" Q
S BMXSBFLD=$O(^DD(BMXSUBFN,"B",BMXB,0))
I '+BMXSBFLD S BMXERR="Related field not found" Q
;
;Find a normal index on that field
;Set up for call to CHKCR^BMXSQL7
N BMXEXEC
I '$$CHKCR^BMXSQL7(BMXSUBFN,BMXSBFLD,.BMXEXEC) S BMXERR="Related File not indexed" Q
;
;
S BMXFF(C,"JOIN")="One-to-many Join"
;
;Call SETMFL^BMXSQL5 to set up the iteration code
D SETMFL^BMXSQL5(BMXUPFN,BMXSUBFN,BMXEXEC,1,1)
;
;
;Upfile is the mainfile, Subfile is the related file
;BMXOFF is 1 but What is BMXGL?
;
Q
;
ERROR Q
BMXSQL7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
CHKCR(BMXFNUM,BMXFLDNU,BMXRET) ;Returns cross reference to iterate on for related file
+1 NEW BMXREF,BMXHIT,BMXRNOD,BMXTMP,BMXTMPV,BMXTMPI,BMXTMPP,BMXPFFN,BMXPFF,Q
+2 NEW BMXHIT,BMXREF,BMXGL,BMXNOD,BMXRNAM,BMXTMPL,BMXTMPN,BMXTST
+3 ;
+4 SET BMXNOD=^DD(BMXFNUM,BMXFLDNU,0)
+5 ;Subfile global
SET BMXGL=^DIC(BMXFNUM,0,"GL")
+6 SET BMXREF=0
SET BMXHIT=0
SET Q=$CHAR(34)
SET BMXRET=""
+7 FOR
SET BMXREF=$ORDER(^DD(BMXFNUM,BMXFLDNU,1,BMXREF))
IF '+BMXREF
QUIT
Begin DoDot:1
+8 IF '$DATA(^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0))
QUIT
+9 SET BMXRNOD=^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0)
+10 IF $PIECE(BMXRNOD,U,3)]""
QUIT
+11 SET BMXRNAM=$PIECE(BMXRNOD,U,2)
+12 SET BMXTMP=BMXGL_Q_BMXRNAM_Q_")"
+13 SET BMXTST=$PIECE(BMXTMP,")")_",IEN0,"
+14 IF '$DATA(@BMXTMP)
QUIT
+15 SET BMXTMPV=0
SET BMXTMPV=$ORDER(@BMXTMP@(BMXTMPV))
+16 IF BMXTMPV=""
QUIT
+17 SET BMXTMP=BMXGL_Q_BMXRNAM_Q_","_Q_BMXTMPV_Q_")"
+18 SET BMXTMPI=0
SET BMXTMPI=$ORDER(@BMXTMP@(BMXTMPI))
+19 SET BMXTMP=$SELECT(BMXGL[",":$PIECE(BMXGL,",")_")",1:$PIECE(BMXGL,"("))
+20 IF '$DATA(@BMXTMP@(BMXTMPI))
QUIT
+21 SET BMXTMPL=$PIECE(BMXNOD,U,4)
+22 SET BMXTMPP=$PIECE(BMXTMPL,";",2)
+23 SET BMXTMPL=$PIECE(BMXTMPL,";")
+24 IF BMXTMPL=""
QUIT
+25 SET BMXTMP=BMXGL_BMXTMPI_")"
+26 IF '$DATA(@BMXTMP@(BMXTMPL))
QUIT
+27 SET BMXTMPN=@BMXTMP@(BMXTMPL)
+28 SET BMXTMPP=$PIECE(BMXTMPN,"^",BMXTMPP)
+29 IF BMXTMPP=BMXTMPV
SET BMXRET=BMXTST
SET BMXHIT=1
End DoDot:1
IF BMXHIT
QUIT
+30 QUIT BMXHIT
+31 ;
+32 ;
WHERE ;EP - WHERE-clause processing
+1 ;
+2 ;Set up the defualt iterator in BMXX(1) to scan the entire file.
+3 ;For now, just use first file in the FROM group
+4 ;Later, pick the smallest file if more than one file
+5 ;
+6 ;Set up BMXFF array for each expression element
+7 ; BMXFF(n)=FILENAME^FIELDNAME^OPERATOR^VALUE^FILENUMBER^FIELDNUMBER
+8 ; ^FILE GLOBAL^FIELD DATA LOCATION
+9 ; BMXFF(n,0)=Field descriptor ^DD(FILE,FIELD,0)
+10 ;
+11 NEW BMXGL,BMXOP,BMXTYP,BMXV,BMXV1,BMXV2,BMXFILE,BMXTMP
+12 NEW BMXINTNL,BMXTMPLT
+13 NEW BMXIEN
+14 SET BMXGL=^DIC(BMXFO(1),0,"GL")
+15 SET BMXX=1
+16 SET BMXX(1)="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX "
+17 SET BMXTMP=BMXGL
+18 IF BMXTMP[","
SET BMXTMP=$TRANSLATE(BMXTMP,",",")")
+19 IF '$TEST
SET BMXTMP=$PIECE(BMXTMP,"(",1)
+20 IF $DATA(@BMXTMP@("B"))
Begin DoDot:1
+21 SET BMXX(1)="S BMXTMP=0 F S BMXTMP=$O("_BMXGL_$CHAR(34)_"B"_$CHAR(34)_",BMXTMP)) Q:BMXTMP="""" S D0=0 F S D0=$O("_BMXGL_$CHAR(34)_"B"_$CHAR(34)_",BMXTMP,D0)) Q:'+D0 Q:BMXM>BMXXMAX "
End DoDot:1
+22 ;
+23 ;--->BMXFF array:
+24 ;
+25 SET T=$GET(BMXTK("WHERE"))
+26 SET BMXFF=0
SET C=0
+27 IF '+T
QUIT
+28 FOR
SET T=$ORDER(BMXTK(T))
IF '+T
QUIT
IF T=$GET(BMXTK("ORDER BY"))
QUIT
IF T=$GET(BMXTK("GROUP BY"))
QUIT
Begin DoDot:1
+29 ;Get the file of the field
+30 IF "AND^OR^(^)"[BMXTK(T)
Begin DoDot:2
+31 SET C=C+1
+32 SET BMXFF(C)=BMXTK(T)
+33 SET BMXFF=C
End DoDot:2
QUIT
+34 SET BMXTK(T)=$TRANSLATE(BMXTK(T),"_"," ")
+35 SET BMXTK(T)=$TRANSLATE(BMXTK(T),"'","")
+36 SET BMXINTNL=0
+37 SET BMXTMPLT=0
+38 SET BMXIEN=0
+39 IF BMXTK(T)["INTERNAL["
SET BMXINTNL=1
SET BMXTK(T)=$PIECE(BMXTK(T),"[",2)
SET BMXTK(T)=$PIECE(BMXTK(T),"]",1)
+40 IF BMXTK(T)["TEMPLATE["
SET BMXTMPLT=1
SET BMXTK(T)=$PIECE(BMXTK(T),"[",2)
SET BMXTK(T)=$PIECE(BMXTK(T),"]",1)
SET BMXIEN=1
+41 IF BMXTK(T)["BMXIEN"
SET BMXIEN=1
+42 SET BMXFILE=$$FLDFILE^BMXSQL2(BMXTK(T))
+43 IF $DATA(BMXERR)
QUIT
+44 SET C=C+1
+45 ;This is a count of the where fields
SET BMXFF=C
+46 IF BMXFILE]""
Begin DoDot:2
+47 ;FILENAME
SET $PIECE(BMXFF(C),U,1)=$PIECE(BMXFILE,U,1)
+48 ;FIELDNAME
SET $PIECE(BMXFF(C),U,2)=$PIECE(BMXFILE,U,2)
+49 ;FILENUMBER
SET $PIECE(BMXFF(C),U,5)=$PIECE(BMXFILE,U,3)
+50 ;FIELDNUMBER
SET $PIECE(BMXFF(C),U,6)=$PIECE(BMXFILE,U,4)
+51 IF $PIECE(BMXFILE,U,3)
IF $DATA(^DIC($PIECE(BMXFILE,U,3),0,"GL"))
SET $PIECE(BMXFF(C),U,7)=^DIC($PIECE(BMXFILE,U,3),0,"GL")
+52 IF BMXIEN
SET BMXFF(C,0)="IEN"
SET BMXFF(C,"IEN")=1
SET BMXFF(C,"TYPE")="IEN"
+53 IF '$TEST
SET BMXFF(C,0)=$SELECT(+$PIECE(BMXFILE,U,3):^DD($PIECE(BMXFILE,U,3),$PIECE(BMXFILE,U,4),0),1:"")
+54 IF BMXINTNL
SET BMXFF(C,"INTERNAL")=1
End DoDot:2
+55 ;
+56 ;If BMXFF(C) is a pointer, traverse pointer chain to retrieve type
+57 IF $PIECE(BMXFF(C,0),U,2)["P"
Begin DoDot:2
+58 ;B ;WHERE Pointer Type
+59 NEW BMXFILN,BMXFLDN,BMXDD
+60 SET BMXDD=BMXFF(C,0)
+61 FOR
IF $PIECE(BMXDD,U,2)'["P"
QUIT
IF $PIECE(BMXDD,U,2)["P"
Begin DoDot:3
+62 SET BMXFILN=$PIECE(BMXDD,U,2)
+63 SET BMXFILN=+$PIECE(BMXFILN,"P",2)
+64 SET BMXDD=^DD(BMXFILN,".01",0)
End DoDot:3
+65 SET BMXFF(C,"TYPE")=$SELECT($PIECE(BMXDD,U,2)["D":"DATE",$PIECE(BMXDD,U,2)["S":"SET",1:"OTHER")
+66 IF BMXFF(C,"TYPE")="SET"
SET $PIECE(BMXFF(C,"TYPE"),U,2)=$PIECE(BMXDD,U,3)
End DoDot:2
+67 ;B ;WHERE Set Type
+68 ;Set
IF ($PIECE(BMXFF(C,0),U,2)["S")!($PIECE($GET(BMXFF(C,"TYPE")),U)="SET")
Begin DoDot:2
+69 NEW BMXSET,BMXSETP
+70 IF $PIECE(BMXFF(C,0),U,2)["S"
Begin DoDot:3
+71 SET BMXFF(C,"TYPE")="SET"
+72 SET $PIECE(BMXFF(C,"TYPE"),U,2)=$PIECE(BMXFF(C,0),U,3)
End DoDot:3
+73 SET BMXSET=$PIECE(BMXFF(C,"TYPE"),U,2)
+74 FOR J=1:1:$LENGTH(BMXSET,";")
Begin DoDot:3
+75 SET BMXSETP=$PIECE(BMXSET,";",J)
+76 IF BMXSETP=""
QUIT
+77 SET BMXFF(C,"SET",$PIECE(BMXSETP,":",2))=$PIECE(BMXSETP,":")
End DoDot:3
End DoDot:2
+78 ;
+79 ;Set up comparisons based on operators
+80 SET T=T+1
+81 SET BMXOP=BMXTK(T)
+82 IF BMXTMPLT
SET BMXOP="="
+83 IF "^<^>^=^[^<>^>=^<=^LIKE"[BMXOP
Begin DoDot:2
+84 SET $PIECE(BMXFF(C),U,3)=BMXTK(T)
+85 ;Get the comparison value
+86 SET T=T+1
+87 SET BMXTMP=BMXTK(T)
+88 SET BMXTMP=$TRANSLATE(BMXTMP,"'","")
+89 IF BMXOP="LIKE"
SET BMXTMP=$PIECE(BMXTMP,"%")
SET $PIECE(BMXFF(C),U,4)=BMXTMP
QUIT
+90 IF BMXTMPLT
DO TMPLATE
QUIT
+91 IF BMXTMP="*"
SET T=T+1
SET BMXTMP=BMXTK(T)
DO OTM
QUIT
+92 ;This is a join ;TODO: Extended pointers
IF BMXTMP["."
IF BMXTK(T)'["'"
Begin DoDot:3
+93 ;Setting BMXFJ("JOIN"
+94 SET BMXTMP=BMXTK(T)
+95 IF $DATA(BMXF($PIECE(BMXTMP,".")))
IF BMXF($PIECE(BMXTMP,"."))=BMXFO(1)
Begin DoDot:4
+96 SET BMXTMP=BMXTK(T-2)
+97 DO OTM
End DoDot:4
QUIT
+98 NEW BMXJN
+99 SET BMXFF(C,"JOIN")="Pointer chain"
+100 SET BMXJN=+$PIECE($PIECE(BMXFF(C,0),U,2),"P",2)
+101 SET BMXFJ("JOIN",+$PIECE($PIECE(BMXFF(C,0),U,2),"P",2))=C
+102 ;IHS Only -- auto join PATIENT to VA PATIENT
IF +$PIECE($PIECE(BMXFF(C,0),U,2),"P",2)=2
SET BMXFJ("JOIN",9000001)=C
End DoDot:3
+103 ;Date
IF ($PIECE(BMXFF(C,0),U,2)["D")!($GET(BMXFF(C,"TYPE"))="DATE")
Begin DoDot:3
+104 IF $DATA(BMXFF(C,"INTERNAL"))
QUIT
+105 IF BMXTMP]""
SET X=BMXTMP
SET %DT="T"
DO ^%DT
SET BMXTMP=Y
End DoDot:3
+106 IF $PIECE($GET(BMXFF(C,"TYPE")),U)="SET"
Begin DoDot:3
+107 IF $DATA(BMXFF(C,"INTERNAL"))
QUIT
+108 IF BMXTMP=""
QUIT
+109 IF $GET(BMXFF(C,"SET",BMXTMP))=""
SET BMXTMP="ZZZZZZ"
QUIT
+110 SET BMXTMP=$GET(BMXFF(C,"SET",BMXTMP))
End DoDot:3
+111 SET $PIECE(BMXFF(C),U,4)=BMXTMP
+112 QUIT
End DoDot:2
QUIT
+113 IF BMXOP="BETWEEN"
Begin DoDot:2
+114 SET $PIECE(BMXFF(C),U,3)="BETWEEN"
+115 ;Get the comparison value
+116 SET T=T+1
+117 SET BMXV1=BMXTK(T)
+118 IF BMXV1["'"
SET BMXV1=$PIECE(BMXV1,"'",2)
+119 SET T=T+1
+120 IF BMXTK(T)'="AND"
SET BMXERR="'BETWEEN' VALUES NOT SPECIFIED"
DO ERROR
QUIT
+121 SET T=T+1
+122 SET BMXV2=BMXTK(T)
+123 IF BMXV2["'"
SET BMXV2=$PIECE(BMXV2,"'",2)
+124 ;Date
IF ($PIECE(BMXFF(C,0),U,2)["D")!($GET(BMXFF(C,"TYPE"))="DATE")
Begin DoDot:3
+125 IF $DATA(BMXFF(C,"INTERNAL"))
QUIT
+126 SET X=BMXV1
SET %DT="T"
DO ^%DT
SET BMXV1=Y
+127 SET X=BMXV2
SET %DT="T"
DO ^%DT
SET BMXV2=Y
End DoDot:3
+128 IF BMXV1>BMXV2
SET BMXTMP=BMXV1
SET BMXV1=BMXV2
SET BMXV2=BMXTMP
+129 SET $PIECE(BMXFF(C),U,4)=BMXV1_"~"_BMXV2
+130 QUIT
End DoDot:2
+131 IF $PIECE(BMXFF(C),U,3)=""
SET BMXERR="INVALID OPERATOR"
DO ERROR
QUIT
+132 IF $DATA(BMXTK(T+1))
IF BMXTK(T+1)["[INDEX:"
Begin DoDot:2
+133 SET T=T+1
+134 NEW BMXIND
+135 SET BMXIND=$PIECE(BMXTK(T),"INDEX:",2)
+136 IF BMXIND["]"
SET BMXIND=$PIECE(BMXIND,"]")
+137 IF BMXIND["'"
SET BMXIND=$PIECE(BMXIND,"'",2)
+138 SET BMXFF("INDEX")=BMXIND
End DoDot:2
+139 QUIT
End DoDot:1
IF $DATA(BMXERR)
QUIT
+140 ;
+141 IF $DATA(BMXERR)
QUIT
+142 DO JOIN^BMXSQL4
+143 QUIT
+144 ;
TMPLATE ;
+1 NEW BMXTNUM,BMXTNOD
+2 IF BMXTMP["["
SET BMXTMP=$PIECE(BMXTMP,"[",2)
SET BMXTMP=$PIECE(BMXTMP,"]")
+3 SET BMXTMP=$TRANSLATE(BMXTMP,"_"," ")
+4 ;Test template validity
+5 IF '$DATA(^DIBT("B",BMXTMP))
SET BMXERR="TEMPLATE NOT FOUND"
DO ERROR
QUIT
+6 SET BMXTNUM=$ORDER(^DIBT("B",BMXTMP,0))
+7 IF '$DATA(^DIBT(BMXTNUM,0))
SET BMXERR="TEMPLATE NOT FOUND"
DO ERROR
QUIT
+8 SET BMXTNOD=^DIBT(BMXTNUM,0)
+9 IF $PIECE(BMXTNOD,U,4)'=$PIECE(BMXFF(C),U,5)
SET BMXERR="TEMPLATE DOES NOT MATCH FILE"
DO ERROR
QUIT
+10 IF '$DATA(^DIBT(BMXTNUM,1))
SET BMXERR="TEMPLATE HAS NO ENTRIES"
DO ERROR
QUIT
+11 SET BMXFF(C,0)="IEN"
SET BMXFF(C,"IEN")="TEMPLATE"
SET BMXFF(C,"TYPE")="IEN"
+12 SET $PIECE(BMXFF(C),U,4)=BMXTMP
+13 ;
+14 QUIT
+15 ;
OTM ;One-To-Many
+1 NEW BMXUPFN,BMXSUBFN,BMXA,BMXB,BMXSBFLD,BMXFNAM
+2 IF BMXTMP["INTERNAL["
SET BMXTMP=$PIECE(BMXTMP,"INTERNAL[",2)
SET BMXTMP=$PIECE(BMXTMP,"]")
+3 SET BMXUPFN=BMXFO(1)
+4 SET BMXA=$TRANSLATE($PIECE(BMXTMP,"."),"_"," ")
+5 SET BMXB=$TRANSLATE($PIECE(BMXTMP,".",2),"_"," ")
+6 ;Required by SETMFL. Won't work if filename BMXB [ "."
SET BMXFNAM=BMXB
+7 ;Get the subfile
+8 IF '$DATA(BMXF(BMXA))
SET BMXERR="Related File Not Found"
QUIT
+9 SET BMXSUBFN=BMXF(BMXA)
+10 IF '$DATA(^DD(BMXSUBFN,0))
SET BMXERR="Related file not found"
QUIT
+11 ;Get the field that points to the main file
+12 IF '$DATA(^DD(BMXSUBFN,"B",BMXB))
SET BMXERR="Related field not found"
QUIT
+13 SET BMXSBFLD=$ORDER(^DD(BMXSUBFN,"B",BMXB,0))
+14 IF '+BMXSBFLD
SET BMXERR="Related field not found"
QUIT
+15 ;
+16 ;Find a normal index on that field
+17 ;Set up for call to CHKCR^BMXSQL7
+18 NEW BMXEXEC
+19 IF '$$CHKCR^BMXSQL7(BMXSUBFN,BMXSBFLD,.BMXEXEC)
SET BMXERR="Related File not indexed"
QUIT
+20 ;
+21 ;
+22 SET BMXFF(C,"JOIN")="One-to-many Join"
+23 ;
+24 ;Call SETMFL^BMXSQL5 to set up the iteration code
+25 DO SETMFL^BMXSQL5(BMXUPFN,BMXSUBFN,BMXEXEC,1,1)
+26 ;
+27 ;
+28 ;Upfile is the mainfile, Subfile is the related file
+29 ;BMXOFF is 1 but What is BMXGL?
+30 ;
+31 QUIT
+32 ;
ERROR QUIT
