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

BMXSQL5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
        ;;2.2;BMX;;Sep 07, 2010
        ;
        ;
SELECT  ;EP - Get field names into BMXFLD("NAME")="FILE#^FIELD#"
        N BMXA,BMXB,BMXS,BMXSINGL
        N BMXINTNL
        S T=$G(BMXTK("SELECT"))
        I '+T S BMXERR="'SELECT' CLAUSE NOT FOUND" D ERRTACK^BMXSQL(1) Q
        S BMXFLD=0
        N BMXOFF,BMXGS1,BMXLVL
        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)
        Q
        ;
SALIAS  ;
        Q:'+$O(BMXTK(T))
        N V
        S V=T+1
        Q:$G(BMXTK(V))=","
        Q:V=$G(BMXTK("FROM"))
        S:BMXTK(V)["'" BMXTK(V)=$P(BMXTK(V),"'",2)
        S BMXFLDA(BMXFILE,BMXFLDN)=BMXTK(V)
        S $P(BMXFLDO(BMXFLDO-1),U,6)=BMXTK(V)
        S T=T+1
        Q
        ;
S1      ;
        S BMXTK(T)=$TR(BMXTK(T),"_"," ")
        ;Check for INTERNAL[ modifier
        S BMXGS1=0
        S BMXINTNL="E"
        I BMXTK(T)["[" S BMXINTNL="I",BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1)
        ;If explicit file name
        S BMXSINGL=0
        I BMXTK(T)["." D  G:BMXGS1 S1 G:BMXSINGL NOTEXP Q
        . ;Before FILE.FIELD Parsing
        . S BMXA=$P(BMXTK(T),".",1,BMXOFF) ;File Name
        . I '$D(BMXF(BMXA)) D  Q:$D(BMXERR)  Q:BMXSINGL
        . . I $D(^DD(BMXFO(1),"B",BMXTK(T))),BMXOFF=1 S BMXSINGL=1 Q
        . . S BMXERR="FILE NOT FOUND" D ERRTACK^BMXSQL(1) Q
        . S BMXB=$P(BMXTK(T),".",1+BMXOFF,99) ;Field Name TODO: Test here for multiple in extended pointer -- FILE.MULTIPLE.FIELD
        . N BMXLAST S BMXLAST=0
        . I $L(BMXB,".")>1 D  Q:'BMXLAST  ;Multiple
        . . N BMXFNUM,BMXFNAM,BMXFNOD,BMXSUBFN,BMXUPFN,BMXGL,W,BMXFOUND
        . . ;Multiple or Field-name with period?
        . . S BMXFOUND=0
        . . F W=1:1:$L(BMXTK(T),".") D  Q:BMXFOUND
        . . . S BMXOFF=BMXOFF+1
        . . . I $D(^DD(BMXF(BMXA),"B",$P(BMXB,".",1,W))) D
        . . . . S BMXFNAM=$P(BMXB,".",1,W)
        . . . . S BMXFOUND=1
        . . . . S:W=$L(BMXB,".") BMXLAST=1
        . . . . S BMXLVL=BMXLVL+1
        . . ;
        . . Q:BMXLAST
        . . S BMXF=BMXF+1
        . . S BMXFNUM=$O(^DD(BMXF(BMXA),"B",BMXFNAM,0)) ;FieldNumber
        . . S BMXFNOD=^DD(BMXF(BMXA),BMXFNUM,0)
        . . S BMXGL=$P(BMXFNOD,U,4),BMXGL=$P(BMXGL,";")
        . . S BMXSUBFN=+$P(BMXFNOD,U,2) ;Subfile Number
        . . S BMXUPFN=^DD(BMXSUBFN,0,"UP") ;Parent File Number
        . . D SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXLVL,0)
        . . S BMXGS1=1
        . S:BMXB["'" BMXB=$P(BMXB,"'",2)
        . I BMXB="BMXIEN" D  Q
        . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
        . . D SELECT1
        . I BMXB="*" D  Q  ;All fields in file BMXA
        . . ;BMXIEN Has to be first because ADO doesn't handle it well if a DATE type column is returned first
        . . S BMXB="BMXIEN"
        . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
        . . D SELECT1
        . . S BMXB=0 F  S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB=""  D
        . . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
        . . . D SELECT1
        . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . I '$D(^DD(BMXF(BMXA),"B",BMXB)) S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
        . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
        . D SELECT1
        . Q
        ;
NOTEXP  ;File not explicit so Loop through files in BMXF to locate field name
        ;
        I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2)
        S C=0,BMXA=""
        I BMXTK(T)="BMXIEN" D  Q
        . S BMXB=BMXTK(T)
        . S BMXA=BMXFO(1) ;File defaults to first named file in FROM
        . S BMXA=BMXFNX(BMXA)
        . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
        . D SELECT1
        F  S BMXA=$O(BMXF(BMXA)) Q:BMXA=""  D  Q:$D(BMXERR)
        . S BMXB=BMXTK(T)
        . I BMXB="*" D  Q  ;All fields in file BMXA
        . . S BMXB="BMXIEN"
        . . S BMXA=BMXFO(1) ;File defaults to first named file in FROM
        . . S BMXA=BMXFNX(BMXA)
        . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001"
        . . D SELECT1
        . . S BMXB=0 F  S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB=""  D
        . . . S BMXS=BMXA_"."_BMXB
        . . . S BMXFLD(BMXS)=BMXF(BMXA)
        . . . S $P(BMXFLD(BMXS),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
        . . . D SELECT1
        . . . S C=1
        . I $D(^DD(BMXF(BMXA),"B",BMXTK(T))) D  Q:$D(BMXERR)
        . . S C=C+1
        . . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERRTACK^BMXSQL(1) Q
        . . S BMXB=BMXTK(T) ;Field Name
        . . I BMXB["'" S BMXB=$P(BMXB,"'",2)
        . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA)
        . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0))
        . . D SELECT1
        . . Q
        . Q
        I C=0 S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q
        Q
        ;
SELECT1 ;
        N BMXGNOD,BMXFILE,BMXGNOD1
        S BMXFLDN=$P(BMXFLD(BMXA_"."_BMXB),"^",2)
        S BMXFILE=$P(BMXFLD(BMXA_"."_BMXB),U)
        S BMXFLDN(BMXFILE,BMXFLDN)=BMXB
        I BMXFLDN=".001" S BMXGNOD="IEN",BMXGNOD1="",$P(BMXGNOD1,U,2)="N"
        E  S BMXGNOD1=^DD(BMXFILE,BMXFLDN,0)
        S BMXGNOD=$P(BMXGNOD1,"^",4)
        S $P(BMXFLD(BMXA_"."_BMXB),"^",3)=$P(BMXGNOD,";")
        S $P(BMXFLD(BMXA_"."_BMXB),"^",4)=$P(BMXGNOD,";",2)
        S $P(BMXFLD(BMXA_"."_BMXB),"^",5)=BMXINTNL
        S BMXFLDO(BMXFLD)=BMXFILE_"^"_BMXFLDN_"^"_BMXINTNL
        I +$P(BMXGNOD1,U,2) D  ;Check for WP
        . S BMXGNOD1=+$P(BMXGNOD1,U,2)
        . Q:'$D(^DD(BMXGNOD1,.01,0))
        . I $P(^DD(BMXGNOD1,.01,0),U,2)["W" S $P(BMXFLDO(BMXFLD),U,4)="W"
        ;HMW20030630 Modified next line to make data type of Internal[] for pointer an Integer.
        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
        I $P(BMXGNOD1,U,2)["D" S $P(BMXFLDO(BMXFLD),U,5)="D"
        I $P(BMXGNOD1,U,2)["N" D
        . N Z
        . S Z=$P(BMXGNOD1,U,2)
        . I +$P(Z,",",2)=0 S $P(BMXFLDO(BMXFLD),U,5)="I" ;Integer
        S BMXFLDOX(BMXFILE,BMXFLDN,BMXINTNL)=BMXFLD
        S BMXFLD=BMXFLD+1
        S BMXFLDO=BMXFLD
        D SALIAS
        Q
        ;
SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXOFF,BMXOTM)          ;EP
        ;
        ;BMXOTM = One-To-Many
        N BMXUPG
        S BMXMFL("PARENT",BMXSUBFN)=BMXUPFN
        S BMXMFL(BMXUPFN,"SUBFILE",BMXSUBFN)=""
        S BMXMFL("SUBFILE",BMXUPFN,BMXSUBFN)=""
        S BMXUPG=BMXMFL(BMXUPFN,"GLOC") ;Parent File Global Set in FROM clause
        S BMXFNAM=BMXA_"."_BMXFNAM ;TODO: Regression test this line with OTM
        I 'BMXOTM S BMXMFL(BMXSUBFN,"GLOC")=BMXUPG_"IEN"_(BMXOFF-1)_","_$C(34)_BMXGL_$C(34)_","
        E  S BMXMFL(BMXSUBFN,"GLOC")=BMXGL,BMXMFL(BMXSUBFN,"OTM")=""
        S BMXMFL(BMXSUBFN,"MULT")="S IEN"_BMXOFF_"=0 F  S IEN"_BMXOFF_"=$O("_BMXMFL(BMXSUBFN,"GLOC")_"IEN"_BMXOFF_")) Q:'+IEN"_BMXOFF_"  "
        I $D(BMXMFL(BMXUPFN,"MULT")) S BMXMFL(BMXSUBFN,"MULT")=BMXMFL(BMXUPFN,"MULT")_" "_BMXMFL(BMXSUBFN,"MULT")
        I 'BMXOTM S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" F J=0:1:"_BMXOFF_" S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
        E  S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" S J=1 S BMXIENS=@(""IEN""_J)_"",""_BMXIENS"
        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)"
        D F1^BMXSQL(BMXF,BMXFNAM,BMXSUBFN)
        ;
        Q
        ;
PTYPE(BMXGNOD1) ;
        ;Traverse pointer chain to retrieve data type of pointed-to field
        N BMXFILE
        I $P(BMXGNOD1,U,2)'["P" Q BMXGNOD1
        S BMXFILE=$P(BMXGNOD1,U,2)
        S BMXFILE=+$P(BMXFILE,"P",2)
        S BMXGNOD1=$G(^DD(BMXFILE,".01",0))
        S BMXGNOD1=$$PTYPE(BMXGNOD1)
        Q BMXGNOD1