BMXSQL6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
;;4.0;BMX;;JUN 28, 2010
;
;
WRITE ;EP
N BMXFN,C,BMXN,BMXGF,BMXA,BMXFLDF,N,A,IEN0,I
N BMXCNT,BMXCNTB,BMXLEN,BMXLTMP,BMXNUM,BMXORD,BMXTYP
N BMXCFN,BMXCFNX,F,BMXROOT,BMXCID,BMXZ ;From MAKEC
N BMXREC,BMXCHAIN ;TODO: COMMENT AFTER TESTING
N BMXIENS
;Set up FIELD value for GETS^DIQ call
; BMXFLD("NAME")="FILE#^FIELD#"
; Need: BMXFLDN(FieldNumber)
; and : BMXFLDO(SelectOrder)
; Get file number -- for now just use first file in array
; TODO: Set up same main file and related files here and in enumerator
S C=0,BMXN=""
N F
S BMXGF=0
S F=0 F S F=$O(BMXF(F)) Q:F="" S BMXFN=BMXF(F) D
. S C=0,BMXN=-1 F S BMXN=$O(BMXFLDO(BMXN)) Q:BMXN="" D
. . Q:$P(BMXFLDO(BMXN),U)'=BMXFN
. . I $P(BMXFLDO(BMXN),U,2)=".001" S BMXGF=BMXGF+1 Q
. . S C=C+1
. . S $P(BMXGF(BMXFN),";",C)=$P(BMXFLDO(BMXN),U,2)
. . S:'$D(BMXGF(BMXFN,"INTERNAL")) BMXGF(BMXFN,"INTERNAL")="E"
. . I $P(BMXFLDO(BMXN),U,3)="I" S BMXGF(BMXFN,"INTERNAL")="IE"
. . S BMXGF=BMXGF+1
. . Q
. Q
;
I BMXGF>1 K BMXTK("DISTINCT") ;Distinct supported for only one field
S N=0,BMXFLDF=0,I=1,BMXNUM=0
D FIELDS
D MAKEC
;
;
I BMXCOL D COLTYPE^BMXSQL,ERRTACK^BMXSQL(I) Q ;Column info only
;
S BMXA="A"
N G,R
;---> Loop through results global
F S N=$O(^BMXTMP($J,N)) Q:'+N D
. K A
. S R=0 F S R=$O(BMXFO(R)) Q:'+R D ;For each file in ORDER array
. . S IEN0=0
. . S BMXFN=BMXFO(R)
. . Q:$D(BMXMFL(BMXFN,"MULT"))
. . I R=1 S IEN0=^BMXTMP($J,N) ;Primary file
. . I R>1,$D(BMXFJ("JOIN",BMXFN)) D ;Joined file
. . . S IEN0=0
. . . S G=BMXFJ("JOIN",BMXFN)
. . . S V=BMXFF(G,"JOIN","IEN")
. . . S @V=^BMXTMP($J,N)
. . . X BMXFF(G,"JOIN")
. . I +IEN0 D ;Removed $D(BMXGF(BMXFN)) for mult fld on extdnd ptr
. . . D SUBFILE(BMXFN)
. . I +IEN0,$D(BMXFLDN(BMXFN,.001)) D SETIEN(IEN0,BMXFN)
. . ;
. . I 0,R>1,$D(BMXMFL(BMXFN,"MULT")) D ;Multiple field
. . . Q:'+IEN0
. . . Q:'$D(BMXGF(BMXFN)) ;Intervening multiple
. . . ;Call GETS for each subentry in multiple
. . . X BMXMFL(BMXFN,"EXEC")
. S F=0,BMXCNT=0
. ;
. D RECORD
. D OUT
;
;
;---> Tack on Error Delimiter and any error.
S I=I+1
D ERRTACK^BMXSQL(I)
D COLTYPE^BMXSQL
Q
;
SETIEN(BMXIEN,BMXFN) ;
;B ;SETIEN
Q:'$D(BMXFLDN(BMXFN,.001))
Q:'+BMXIEN
S A(BMXFN,BMXIEN_",",.001,"E")=BMXIEN
Q
;
SUBFILE(BMXFN) ;
;Execute GETS for Any fields in BMXGF(SUBFILE)
;
;If the subfile itself has subfiles, call SUBFILE(BMXSUBFN)
; (Loop through BMXMFL(BMXFN,"SUBFILE",BMXSUBFN))
I $D(BMXMFL(BMXFN,"SUBFILE")) D
. N BMXSUBFN
. S BMXSUBFN=0
. F S BMXSUBFN=$O(BMXMFL(BMXFN,"SUBFILE",BMXSUBFN)) Q:'+BMXSUBFN D SUBFILE(BMXSUBFN)
. Q
;
I $D(BMXGF(BMXFN)) D
. I '$D(BMXMFL(BMXFN,"MULT")) S BMXMSCR=1 D GETS^DIQ(BMXFN,IEN0_",",BMXGF(BMXFN),BMXGF(BMXFN,"INTERNAL"),BMXA) Q
. E X BMXMFL(BMXFN,"EXEC") Q
;
;
Q
;
FIELDS ;---> Write Field Names
;Field name is TAAAAANAME
;Where T is the field type (T=Text; D=Date)
; AAAAA is the field size (see NUMCHAR routine)
; NAME is the field name
N BMXNUM,BMXFNUM,BMXFNAM,R
K BMXLEN,BMXTYP
S BMXFLDF=1
S BMXNUM=0
;B ;In FIELDS sub
D ;:$D(A)
. I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number
. S BMXFNUM=0
. S BMXFNAM=0
. F R=0:1:(BMXFLDO-1) S BMXFN=$P(BMXFLDO(R),U),BMXFNUM=$P(BMXFLDO(R),U,2) D
. . ;S BMXFNAM=$P(^DD(BMXFN,BMXFNUM,0),"^") ;Get type here
. . S BMXFNAM=BMXFLDN(BMXFN,BMXFNUM)
. . I $P(BMXFLDO(R),U,3)="I" S BMXFNAM="INTERNAL["_BMXFNAM_"]"
. . S BMXFNAM=$TR(BMXFNAM," ","_")
. . I BMXF>1 S BMXFNAM=$TR($P(BMXFNX(BMXFN),".")," ","_")_"."_BMXFNAM
. . S BMXTYP(I)="T"
. . S:$P(BMXFLDO(R),U,5)="D" BMXTYP(I)="D"
. . S:$P(BMXFLDO(R),U,5)="I" BMXTYP(I)="I"
. . S BMXLEN(I)=0 ;Start with length zero
. . ;I $D(BMXFLDA(BMXFN,BMXFNUM)) S BMXFNAM=BMXFLDA(BMXFN,BMXFNUM)
. . I $P(BMXFLDO(R),U,6)]"" S BMXFNAM=$P(BMXFLDO(R),U,6)
. . S ^BMXTEMP($J,I)=BMXFNAM_"^"
. . S I=I+1
. S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30)
Q
;
OUT ;
;Output to BMXTEMP($J
Q:'$D(BMXREC)
N J,K,L,BMXLENT
S J=0 F S J=$O(BMXREC(J)) Q:'+J D
. S K=0 F S K=$O(BMXREC(J,K)) Q:'+K D
. . I +$O(BMXREC(J,K,0)) D Q ;WP
. . . S L=0,BMXLENT=0 F S L=$O(BMXREC(J,K,L)) Q:'+L D
. . . . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
. . . . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
. . . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K,L)
. . . . S BMXLENT=BMXLENT+$L(BMXREC(J,K,L))
. . . I BMXLEN(K)<BMXLENT S BMXLEN(K)=BMXLENT
. . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)=""
. . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)=""
. . I $G(BMXTK("DISTINCT"))="TRUE",BMXREC(J,K)]"" Q:$D(^BMXTEMP($J,"DISTINCT",BMXREC(J,K)))
. . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K)
. . S:$L(BMXREC(J,K))>BMXLEN(K) BMXLEN(K)=$L(BMXREC(J,K))
. . I $G(BMXTK("DISTINCT"))="TRUE" S ^BMXTEMP($J,"DISTINCT",BMXREC(J,K))=""
Q
;
RECORD ;
;For each chain
N C,BMXCQ,BMXLCQ,BMXCQN,BMXLCQN,BMXTRACK,BMXNODE,BMXCNAME,BMXWP
K BMXREC,BMXCHAIN ;TODO: REMOVE AFTER TESTING
D BLDCHN
S BMXREC=0
D RECINI
S C=0 F S C=$O(BMXCHAIN(C)) Q:'+C D
. ;New chain
. ;Go to the end of the chain, writing record pieces as you go
. ;At the end of the chain, write end-of-record marker,increment record counter, copy previous record
. K BMXTRACK
. S BMXCNAME="BMXCHAIN("_C_")"
. S BMXCQN=""
. S BMXCQ=BMXCNAME F S BMXCQ=$Q(@BMXCQ) Q:BMXCQ="" Q:$P(BMXCQ,",")'=("BMXCHAIN("_C) D
. . S BMXNODE=@BMXCQ
. . I $P(BMXNODE,U,2)="" Q
. . S BMXWP=$P(BMXNODE,U,3)
. . S BMXLCQ=$L(BMXCQ,",")
. . S BMXCQN=$Q(@BMXCQ)
. . S BMXLCQN=$L(BMXCQN,",")
. . I BMXWP="W" D
. . . S BMXREC(BMXREC,$P(BMXNODE,U,2),$P(BMXNODE,U,4))=$P(BMXNODE,U)
. . . S BMXTRACK(BMXLCQ-1,$P(BMXNODE,U,2))=BMXNODE
. . E D
. . . S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
. . . S BMXTRACK(BMXLCQ,$P(BMXNODE,U,2))=BMXNODE
. . I BMXCQN="" D EOR Q
. . I $P(BMXCQN,",")'=("BMXCHAIN("_C) D EOR Q
. . I BMXLCQN>BMXLCQ Q
. . I (BMXLCQN>$S(BMXWP="W":7,1:6)) D Q
. . . I ($P(BMXCQ,",",1,BMXLCQ-2)=$P(BMXCQN,",",1,BMXLCQN-2)) Q
. . . D EOR ;End of chain
Q
;
RECINI ;
N J
S BMXREC=BMXREC+1
F J=1:1:BMXFLDO D
. I $P(BMXFLDO(J-1),U,4)="W" S BMXREC(BMXREC,J,999999)="^" Q
. S BMXREC(BMXREC,J)="^"
Q
;
EOR ;
;B ;EOR
N J,K,L,M,I,N
S M=$Q(BMXREC(9999999),-1)
S @M=$TR(@M,"^",$C(30))
Q:BMXCQN=""
I BMXCQN'="" D RECINI
;K BMXTRACK(BMXLCQ) ;Also kill all track levels between current and next level
F K BMXTRACK($O(BMXTRACK(999999),-1)) Q:$O(BMXTRACK(9999999),-1)'>BMXLCQN
S J=0 F S J=$O(BMXTRACK(J)) Q:'+J D ;Level
. S K=0 F S K=$O(BMXTRACK(J,K)) Q:'+K D ;Order
. . I $D(BMXTRACK(J,K)) S BMXNODE=BMXTRACK(J,K) S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U
. . S L=0 F S L=$O(BMXTRACK(J,K,L)) Q:'+L D ;wp node
. . . I $D(BMXTRACK(J,K,L)) S BMXNODE=BMXTRACK(J,K,L) S BMXREC(BMXREC,$P(BMXNODE,U,2),L)=$P(BMXNODE,U)
Q
;
BLDCHN ;
N B
D MAKEB
;D MAKEC
D BUILD
Q
;
MAKEC ;
;MAKE Chain
;How many chains are there?
S BMXZ=0 S BMXCID=1 K BMXCFN
;
;
;Create BMXCHNP(BMXCID)
S F=0 F S F=$O(BMXMFL(F)) Q:'+F I '$D(BMXMFL("SUBFILE",F)),$D(BMXMFL("PARENT",F)) S BMXMFL("BOTTOM",F)=""
N BMXCB,BMXCHNP,BMXP
S BMXCID=0,BMXCB=0,BMXCHNP=0
I $D(BMXMFL("BOTTOM")) F S BMXCB=$O(BMXMFL("BOTTOM",BMXCB)) Q:'BMXCB D
. S BMXCID=BMXCID+1,BMXCHNP=BMXCID
. S BMXCHNP(BMXCID)=BMXCB
. S BMXP=BMXCB
. F Q:'$D(BMXMFL("PARENT",BMXP)) S BMXP=BMXMFL("PARENT",BMXP) S BMXCHNP(BMXCID)=BMXP_U_BMXCHNP(BMXCID)
;
N J,K,L,M
;Create BMXMFL("BASE")="FILE1^FILE2^...^FILEN"
S F=0,M=0,BMXMFL("BASE")="" F S F=$O(BMXMFL(F)) Q:'+F I (('$D(BMXMFL("PARENT",F)))&('$D(BMXMFL(F,"SUBFILE"))))!(BMXFO(1)=F) S M=M+1,$P(BMXMFL("BASE"),U,M)=F ;Changed to make BMXFO(1) always a member of the base
;
;Create BMXCFN(BMXCID,BMXZ,FILE)
I BMXCID=0 S BMXCID=1
S J=0,BMXZ=0 F J=1:1:BMXCID D
. I BMXMFL("BASE")]"" F L=1:1:$L(BMXMFL("BASE"),"^") S F=$P(BMXMFL("BASE"),"^",L) D
. . S BMXZ=BMXZ+100
. . S BMXCFN(J,BMXZ,F)=""
. I +BMXCHNP F K=1:1:$L(BMXCHNP(J),"^") S F=$P(BMXCHNP(J),"^",K) D
. . Q:F=BMXFO(1) ;BMXFO(1) Is always a member of the base
. . S BMXZ=BMXZ+100
. . S BMXCFN(J,BMXZ,F)=""
;
;
;B ;FIXCFN
D FIXCFN
Q
;
BUILD ;Building BMXCHAIN(
N BMXIEN,BMXCID,BMXFLD,BMXCS,BMXINT,BMXCFNC,BMXCFIEN
S BMXCID=0,BMXIEN=0
F S BMXCID=$O(BMXCFN(BMXCID)) Q:'+BMXCID D
. S BMXCFNC=0 F S BMXCFNC=$O(BMXCFN(BMXCID,BMXCFNC)) Q:'+BMXCFNC S BMXCFN=+BMXCFN(BMXCID,BMXCFNC) D
. . S BMXIEN=0 F S BMXIEN=$O(B(BMXCFN,BMXIEN)) Q:BMXIEN="" D
. . . S $P(BMXCFN(BMXCID,BMXCFNC),U,2)=BMXIEN
. . . S BMXFLD=0 F S BMXFLD=$O(B(BMXCFN,BMXIEN,BMXFLD)) Q:'+BMXFLD D
. . . . S BMXINT="D" F S BMXINT=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
. . . . . Q:'$D(BMXFLDOX(BMXCFN,BMXFLD,BMXINT))
. . . . . I $P(BMXFLDO(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)),U,4)="W" D MCWP Q
. . . . . D FIXIEN
. . . . . S BMXCS="BMXCHAIN("_BMXCID_","_$S($L(BMXIEN,",")=2:1,1:2)_","_BMXCFIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
. . . . . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXINT)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)
Q
;
FIXIEN ;
N BMXC,BMXCFN1,BMXOFF
S BMXC=BMXCFNC
S BMXCFIEN=BMXCFN_","_$P(BMXIEN,",",$L(BMXIEN,","))
S BMXOFF=1
F S BMXC=$O(BMXCFN(BMXCID,BMXC),-1) Q:'+BMXC D
. S BMXCFN1=+BMXCFN(BMXCID,BMXC)
. I '$D(BMXMFL(BMXCFN,"OTM")) D
. . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
. . S BMXCFIEN=BMXCFN1_","_$P(BMXIEN,",",$L(BMXIEN,",")-BMXOFF)_","_BMXCFIEN
. I $D(BMXMFL(BMXCFN,"OTM")) D
. . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q
. . S BMXCFIEN=BMXCFN1_$P(BMXCFN(BMXCID,BMXC),U,2)_","_BMXCFIEN
. S BMXOFF=BMXOFF+1
;
;
Q
;
FIXCFN ;
N J,K,L
S J=0 F S J=$O(BMXCFN(J)) Q:'+J D
. S K=0 F S K=$O(BMXCFN(J,K)) Q:'+K D
. . S L=0 F S L=$O(BMXCFN(J,K,L)) Q:'+L D
. . . K BMXCFN(J,K,L)
. . . S BMXCFN(J,K)=L
;
Q
;
MCWP ;
;MAKEC Process WP Field
N BMXIENL,BMXWP
S BMXIENL=1
S:$L(BMXIEN,",")>2 BMXIENL=2
S BMXWP=0
;
F S BMXWP=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXWP)) Q:'+BMXWP D
. S BMXCS="BMXCHAIN("_BMXCID_","_BMXIENL_","_BMXCFN_BMXIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_","_BMXWP_")"
. S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXWP)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)_U_"W"_U_BMXWP
Q
;
;
MAKEB ;
N BMXFILE,BMXIEN,BMXFLD,BMXINT
N BMXSUB,BMXIENR
S BMXFILE=0 F S BMXFILE=$O(A(BMXFILE)) Q:'+BMXFILE D
. S BMXIEN=0 F S BMXIEN=$O(A(BMXFILE,BMXIEN)) Q:'+BMXIEN D
. . S BMXFLD=0 F S BMXFLD=$O(A(BMXFILE,BMXIEN,BMXFLD)) Q:'+BMXFLD D
. . . S BMXINT=0 F S BMXINT=$O(A(BMXFILE,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D
. . . . S BMXIENR=$$REVERSE(BMXIEN)
. . . . S BMXSUB="B("_BMXFILE_","_$C(34)_BMXIENR_$C(34)_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")"
. . . . I $D(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),$P(BMXFLDO(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),U,5)="D" D Q
. . . . . S @BMXSUB=$TR(A(BMXFILE,BMXIEN,BMXFLD,BMXINT),"@"," ")
. . . . S @BMXSUB=A(BMXFILE,BMXIEN,BMXFLD,BMXINT)
Q
;
REVERSE(BMXIEN) ;
N J,T,C
S C=1
F J=$L(BMXIEN,","):-1:1 D
. S $P(T,",",C)=$P(BMXIEN,",",J)
. S C=C+1
Q T
BMXSQL6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
WRITE ;EP
+1 NEW BMXFN,C,BMXN,BMXGF,BMXA,BMXFLDF,N,A,IEN0,I
+2 NEW BMXCNT,BMXCNTB,BMXLEN,BMXLTMP,BMXNUM,BMXORD,BMXTYP
+3 ;From MAKEC
NEW BMXCFN,BMXCFNX,F,BMXROOT,BMXCID,BMXZ
+4 ;TODO: COMMENT AFTER TESTING
NEW BMXREC,BMXCHAIN
+5 NEW BMXIENS
+6 ;Set up FIELD value for GETS^DIQ call
+7 ; BMXFLD("NAME")="FILE#^FIELD#"
+8 ; Need: BMXFLDN(FieldNumber)
+9 ; and : BMXFLDO(SelectOrder)
+10 ; Get file number -- for now just use first file in array
+11 ; TODO: Set up same main file and related files here and in enumerator
+12 SET C=0
SET BMXN=""
+13 NEW F
+14 SET BMXGF=0
+15 SET F=0
FOR
SET F=$ORDER(BMXF(F))
IF F=""
QUIT
SET BMXFN=BMXF(F)
Begin DoDot:1
+16 SET C=0
SET BMXN=-1
FOR
SET BMXN=$ORDER(BMXFLDO(BMXN))
IF BMXN=""
QUIT
Begin DoDot:2
+17 IF $PIECE(BMXFLDO(BMXN),U)'=BMXFN
QUIT
+18 IF $PIECE(BMXFLDO(BMXN),U,2)=".001"
SET BMXGF=BMXGF+1
QUIT
+19 SET C=C+1
+20 SET $PIECE(BMXGF(BMXFN),";",C)=$PIECE(BMXFLDO(BMXN),U,2)
+21 IF '$DATA(BMXGF(BMXFN,"INTERNAL"))
SET BMXGF(BMXFN,"INTERNAL")="E"
+22 IF $PIECE(BMXFLDO(BMXN),U,3)="I"
SET BMXGF(BMXFN,"INTERNAL")="IE"
+23 SET BMXGF=BMXGF+1
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 ;
+27 ;Distinct supported for only one field
IF BMXGF>1
KILL BMXTK("DISTINCT")
+28 SET N=0
SET BMXFLDF=0
SET I=1
SET BMXNUM=0
+29 DO FIELDS
+30 DO MAKEC
+31 ;
+32 ;
+33 ;Column info only
IF BMXCOL
DO COLTYPE^BMXSQL
DO ERRTACK^BMXSQL(I)
QUIT
+34 ;
+35 SET BMXA="A"
+36 NEW G,R
+37 ;---> Loop through results global
+38 FOR
SET N=$ORDER(^BMXTMP($JOB,N))
IF '+N
QUIT
Begin DoDot:1
+39 KILL A
+40 ;For each file in ORDER array
SET R=0
FOR
SET R=$ORDER(BMXFO(R))
IF '+R
QUIT
Begin DoDot:2
+41 SET IEN0=0
+42 SET BMXFN=BMXFO(R)
+43 IF $DATA(BMXMFL(BMXFN,"MULT"))
QUIT
+44 ;Primary file
IF R=1
SET IEN0=^BMXTMP($JOB,N)
+45 ;Joined file
IF R>1
IF $DATA(BMXFJ("JOIN",BMXFN))
Begin DoDot:3
+46 SET IEN0=0
+47 SET G=BMXFJ("JOIN",BMXFN)
+48 SET V=BMXFF(G,"JOIN","IEN")
+49 SET @V=^BMXTMP($JOB,N)
+50 XECUTE BMXFF(G,"JOIN")
End DoDot:3
+51 ;Removed $D(BMXGF(BMXFN)) for mult fld on extdnd ptr
IF +IEN0
Begin DoDot:3
+52 DO SUBFILE(BMXFN)
End DoDot:3
+53 IF +IEN0
IF $DATA(BMXFLDN(BMXFN,.001))
DO SETIEN(IEN0,BMXFN)
+54 ;
+55 ;Multiple field
IF 0
IF R>1
IF $DATA(BMXMFL(BMXFN,"MULT"))
Begin DoDot:3
+56 IF '+IEN0
QUIT
+57 ;Intervening multiple
IF '$DATA(BMXGF(BMXFN))
QUIT
+58 ;Call GETS for each subentry in multiple
+59 XECUTE BMXMFL(BMXFN,"EXEC")
End DoDot:3
End DoDot:2
+60 SET F=0
SET BMXCNT=0
+61 ;
+62 DO RECORD
+63 DO OUT
End DoDot:1
+64 ;
+65 ;
+66 ;---> Tack on Error Delimiter and any error.
+67 SET I=I+1
+68 DO ERRTACK^BMXSQL(I)
+69 DO COLTYPE^BMXSQL
+70 QUIT
+71 ;
SETIEN(BMXIEN,BMXFN) ;
+1 ;B ;SETIEN
+2 IF '$DATA(BMXFLDN(BMXFN,.001))
QUIT
+3 IF '+BMXIEN
QUIT
+4 SET A(BMXFN,BMXIEN_",",.001,"E")=BMXIEN
+5 QUIT
+6 ;
SUBFILE(BMXFN) ;
+1 ;Execute GETS for Any fields in BMXGF(SUBFILE)
+2 ;
+3 ;If the subfile itself has subfiles, call SUBFILE(BMXSUBFN)
+4 ; (Loop through BMXMFL(BMXFN,"SUBFILE",BMXSUBFN))
+5 IF $DATA(BMXMFL(BMXFN,"SUBFILE"))
Begin DoDot:1
+6 NEW BMXSUBFN
+7 SET BMXSUBFN=0
+8 FOR
SET BMXSUBFN=$ORDER(BMXMFL(BMXFN,"SUBFILE",BMXSUBFN))
IF '+BMXSUBFN
QUIT
DO SUBFILE(BMXSUBFN)
+9 QUIT
End DoDot:1
+10 ;
+11 IF $DATA(BMXGF(BMXFN))
Begin DoDot:1
+12 IF '$DATA(BMXMFL(BMXFN,"MULT"))
SET BMXMSCR=1
DO GETS^DIQ(BMXFN,IEN0_",",BMXGF(BMXFN),BMXGF(BMXFN,"INTERNAL"),BMXA)
QUIT
+13 IF '$TEST
XECUTE BMXMFL(BMXFN,"EXEC")
QUIT
End DoDot:1
+14 ;
+15 ;
+16 QUIT
+17 ;
FIELDS ;---> Write Field Names
+1 ;Field name is TAAAAANAME
+2 ;Where T is the field type (T=Text; D=Date)
+3 ; AAAAA is the field size (see NUMCHAR routine)
+4 ; NAME is the field name
+5 NEW BMXNUM,BMXFNUM,BMXFNAM,R
+6 KILL BMXLEN,BMXTYP
+7 SET BMXFLDF=1
+8 SET BMXNUM=0
+9 ;B ;In FIELDS sub
+10 ;:$D(A)
Begin DoDot:1
+11 ;TODO: Change from text to number
IF BMXNUM
SET ^BMXTEMP($JOB,I)="IEN^"
SET BMXLEN(I)=10
SET BMXTYP(I)="T"
SET I=I+1
+12 SET BMXFNUM=0
+13 SET BMXFNAM=0
+14 FOR R=0:1:(BMXFLDO-1)
SET BMXFN=$PIECE(BMXFLDO(R),U)
SET BMXFNUM=$PIECE(BMXFLDO(R),U,2)
Begin DoDot:2
+15 ;S BMXFNAM=$P(^DD(BMXFN,BMXFNUM,0),"^") ;Get type here
+16 SET BMXFNAM=BMXFLDN(BMXFN,BMXFNUM)
+17 IF $PIECE(BMXFLDO(R),U,3)="I"
SET BMXFNAM="INTERNAL["_BMXFNAM_"]"
+18 SET BMXFNAM=$TRANSLATE(BMXFNAM," ","_")
+19 IF BMXF>1
SET BMXFNAM=$TRANSLATE($PIECE(BMXFNX(BMXFN),".")," ","_")_"."_BMXFNAM
+20 SET BMXTYP(I)="T"
+21 IF $PIECE(BMXFLDO(R),U,5)="D"
SET BMXTYP(I)="D"
+22 IF $PIECE(BMXFLDO(R),U,5)="I"
SET BMXTYP(I)="I"
+23 ;Start with length zero
SET BMXLEN(I)=0
+24 ;I $D(BMXFLDA(BMXFN,BMXFNUM)) S BMXFNAM=BMXFLDA(BMXFN,BMXFNUM)
+25 IF $PIECE(BMXFLDO(R),U,6)]""
SET BMXFNAM=$PIECE(BMXFLDO(R),U,6)
+26 SET ^BMXTEMP($JOB,I)=BMXFNAM_"^"
+27 SET I=I+1
End DoDot:2
+28 SET ^BMXTEMP($JOB,I-1)=$EXTRACT(^BMXTEMP($JOB,I-1),1,$LENGTH(^BMXTEMP($JOB,I-1))-1)_$CHAR(30)
End DoDot:1
+29 QUIT
+30 ;
OUT ;
+1 ;Output to BMXTEMP($J
+2 IF '$DATA(BMXREC)
QUIT
+3 NEW J,K,L,BMXLENT
+4 SET J=0
FOR
SET J=$ORDER(BMXREC(J))
IF '+J
QUIT
Begin DoDot:1
+5 SET K=0
FOR
SET K=$ORDER(BMXREC(J,K))
IF '+K
QUIT
Begin DoDot:2
+6 ;WP
IF +$ORDER(BMXREC(J,K,0))
Begin DoDot:3
+7 SET L=0
SET BMXLENT=0
FOR
SET L=$ORDER(BMXREC(J,K,L))
IF '+L
QUIT
Begin DoDot:4
+8 IF '$DATA(^BMXTEMP($JOB,I))
SET ^BMXTEMP($JOB,I)=""
+9 IF $LENGTH(^BMXTEMP($JOB,I))>250
SET I=I+1
SET ^BMXTEMP($JOB,I)=""
+10 SET ^BMXTEMP($JOB,I)=^BMXTEMP($JOB,I)_BMXREC(J,K,L)
+11 SET BMXLENT=BMXLENT+$LENGTH(BMXREC(J,K,L))
End DoDot:4
+12 IF BMXLEN(K)<BMXLENT
SET BMXLEN(K)=BMXLENT
End DoDot:3
QUIT
+13 IF '$DATA(^BMXTEMP($JOB,I))
SET ^BMXTEMP($JOB,I)=""
+14 IF $LENGTH(^BMXTEMP($JOB,I))>250
SET I=I+1
SET ^BMXTEMP($JOB,I)=""
+15 IF $GET(BMXTK("DISTINCT"))="TRUE"
IF BMXREC(J,K)]""
IF $DATA(^BMXTEMP($JOB,"DISTINCT",BMXREC(J,K)))
QUIT
+16 SET ^BMXTEMP($JOB,I)=^BMXTEMP($JOB,I)_BMXREC(J,K)
+17 IF $LENGTH(BMXREC(J,K))>BMXLEN(K)
SET BMXLEN(K)=$LENGTH(BMXREC(J,K))
+18 IF $GET(BMXTK("DISTINCT"))="TRUE"
SET ^BMXTEMP($JOB,"DISTINCT",BMXREC(J,K))=""
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
RECORD ;
+1 ;For each chain
+2 NEW C,BMXCQ,BMXLCQ,BMXCQN,BMXLCQN,BMXTRACK,BMXNODE,BMXCNAME,BMXWP
+3 ;TODO: REMOVE AFTER TESTING
KILL BMXREC,BMXCHAIN
+4 DO BLDCHN
+5 SET BMXREC=0
+6 DO RECINI
+7 SET C=0
FOR
SET C=$ORDER(BMXCHAIN(C))
IF '+C
QUIT
Begin DoDot:1
+8 ;New chain
+9 ;Go to the end of the chain, writing record pieces as you go
+10 ;At the end of the chain, write end-of-record marker,increment record counter, copy previous record
+11 KILL BMXTRACK
+12 SET BMXCNAME="BMXCHAIN("_C_")"
+13 SET BMXCQN=""
+14 SET BMXCQ=BMXCNAME
FOR
SET BMXCQ=$QUERY(@BMXCQ)
IF BMXCQ=""
QUIT
IF $PIECE(BMXCQ,",")'=("BMXCHAIN("_C)
QUIT
Begin DoDot:2
+15 SET BMXNODE=@BMXCQ
+16 IF $PIECE(BMXNODE,U,2)=""
QUIT
+17 SET BMXWP=$PIECE(BMXNODE,U,3)
+18 SET BMXLCQ=$LENGTH(BMXCQ,",")
+19 SET BMXCQN=$QUERY(@BMXCQ)
+20 SET BMXLCQN=$LENGTH(BMXCQN,",")
+21 IF BMXWP="W"
Begin DoDot:3
+22 SET BMXREC(BMXREC,$PIECE(BMXNODE,U,2),$PIECE(BMXNODE,U,4))=$PIECE(BMXNODE,U)
+23 SET BMXTRACK(BMXLCQ-1,$PIECE(BMXNODE,U,2))=BMXNODE
End DoDot:3
+24 IF '$TEST
Begin DoDot:3
+25 SET BMXREC(BMXREC,$PIECE(BMXNODE,U,2))=$PIECE(BMXNODE,U)_U
+26 SET BMXTRACK(BMXLCQ,$PIECE(BMXNODE,U,2))=BMXNODE
End DoDot:3
+27 IF BMXCQN=""
DO EOR
QUIT
+28 IF $PIECE(BMXCQN,",")'=("BMXCHAIN("_C)
DO EOR
QUIT
+29 IF BMXLCQN>BMXLCQ
QUIT
+30 IF (BMXLCQN>$SELECT(BMXWP="W":7,1:6))
Begin DoDot:3
+31 IF ($PIECE(BMXCQ,",",1,BMXLCQ-2)=$PIECE(BMXCQN,",",1,BMXLCQN-2))
QUIT
+32 ;End of chain
DO EOR
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
RECINI ;
+1 NEW J
+2 SET BMXREC=BMXREC+1
+3 FOR J=1:1:BMXFLDO
Begin DoDot:1
+4 IF $PIECE(BMXFLDO(J-1),U,4)="W"
SET BMXREC(BMXREC,J,999999)="^"
QUIT
+5 SET BMXREC(BMXREC,J)="^"
End DoDot:1
+6 QUIT
+7 ;
EOR ;
+1 ;B ;EOR
+2 NEW J,K,L,M,I,N
+3 SET M=$QUERY(BMXREC(9999999),-1)
+4 SET @M=$TRANSLATE(@M,"^",$CHAR(30))
+5 IF BMXCQN=""
QUIT
+6 IF BMXCQN'=""
DO RECINI
+7 ;K BMXTRACK(BMXLCQ) ;Also kill all track levels between current and next level
+8 FOR
KILL BMXTRACK($ORDER(BMXTRACK(999999),-1))
IF $ORDER(BMXTRACK(9999999),-1)'>BMXLCQN
QUIT
+9 ;Level
SET J=0
FOR
SET J=$ORDER(BMXTRACK(J))
IF '+J
QUIT
Begin DoDot:1
+10 ;Order
SET K=0
FOR
SET K=$ORDER(BMXTRACK(J,K))
IF '+K
QUIT
Begin DoDot:2
+11 IF $DATA(BMXTRACK(J,K))
SET BMXNODE=BMXTRACK(J,K)
SET BMXREC(BMXREC,$PIECE(BMXNODE,U,2))=$PIECE(BMXNODE,U)_U
+12 ;wp node
SET L=0
FOR
SET L=$ORDER(BMXTRACK(J,K,L))
IF '+L
QUIT
Begin DoDot:3
+13 IF $DATA(BMXTRACK(J,K,L))
SET BMXNODE=BMXTRACK(J,K,L)
SET BMXREC(BMXREC,$PIECE(BMXNODE,U,2),L)=$PIECE(BMXNODE,U)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
BLDCHN ;
+1 NEW B
+2 DO MAKEB
+3 ;D MAKEC
+4 DO BUILD
+5 QUIT
+6 ;
MAKEC ;
+1 ;MAKE Chain
+2 ;How many chains are there?
+3 SET BMXZ=0
SET BMXCID=1
KILL BMXCFN
+4 ;
+5 ;
+6 ;Create BMXCHNP(BMXCID)
+7 SET F=0
FOR
SET F=$ORDER(BMXMFL(F))
IF '+F
QUIT
IF '$DATA(BMXMFL("SUBFILE",F))
IF $DATA(BMXMFL("PARENT",F))
SET BMXMFL("BOTTOM",F)=""
+8 NEW BMXCB,BMXCHNP,BMXP
+9 SET BMXCID=0
SET BMXCB=0
SET BMXCHNP=0
+10 IF $DATA(BMXMFL("BOTTOM"))
FOR
SET BMXCB=$ORDER(BMXMFL("BOTTOM",BMXCB))
IF 'BMXCB
QUIT
Begin DoDot:1
+11 SET BMXCID=BMXCID+1
SET BMXCHNP=BMXCID
+12 SET BMXCHNP(BMXCID)=BMXCB
+13 SET BMXP=BMXCB
+14 FOR
IF '$DATA(BMXMFL("PARENT",BMXP))
QUIT
SET BMXP=BMXMFL("PARENT",BMXP)
SET BMXCHNP(BMXCID)=BMXP_U_BMXCHNP(BMXCID)
End DoDot:1
+15 ;
+16 NEW J,K,L,M
+17 ;Create BMXMFL("BASE")="FILE1^FILE2^...^FILEN"
+18 ;Changed to make BMXFO(1) always a member of the base
SET F=0
SET M=0
SET BMXMFL("BASE")=""
FOR
SET F=$ORDER(BMXMFL(F))
IF '+F
QUIT
IF (('$DATA(BMXMFL("PARENT",F)))&('$DATA(BMXMFL(F,"SUBFILE"))))!(BMXFO(1)=F)
SET M=M+1
SET $PIECE(BMXMFL("BASE"),U,M)=F
+19 ;
+20 ;Create BMXCFN(BMXCID,BMXZ,FILE)
+21 IF BMXCID=0
SET BMXCID=1
+22 SET J=0
SET BMXZ=0
FOR J=1:1:BMXCID
Begin DoDot:1
+23 IF BMXMFL("BASE")]""
FOR L=1:1:$LENGTH(BMXMFL("BASE"),"^")
SET F=$PIECE(BMXMFL("BASE"),"^",L)
Begin DoDot:2
+24 SET BMXZ=BMXZ+100
+25 SET BMXCFN(J,BMXZ,F)=""
End DoDot:2
+26 IF +BMXCHNP
FOR K=1:1:$LENGTH(BMXCHNP(J),"^")
SET F=$PIECE(BMXCHNP(J),"^",K)
Begin DoDot:2
+27 ;BMXFO(1) Is always a member of the base
IF F=BMXFO(1)
QUIT
+28 SET BMXZ=BMXZ+100
+29 SET BMXCFN(J,BMXZ,F)=""
End DoDot:2
End DoDot:1
+30 ;
+31 ;
+32 ;B ;FIXCFN
+33 DO FIXCFN
+34 QUIT
+35 ;
BUILD ;Building BMXCHAIN(
+1 NEW BMXIEN,BMXCID,BMXFLD,BMXCS,BMXINT,BMXCFNC,BMXCFIEN
+2 SET BMXCID=0
SET BMXIEN=0
+3 FOR
SET BMXCID=$ORDER(BMXCFN(BMXCID))
IF '+BMXCID
QUIT
Begin DoDot:1
+4 SET BMXCFNC=0
FOR
SET BMXCFNC=$ORDER(BMXCFN(BMXCID,BMXCFNC))
IF '+BMXCFNC
QUIT
SET BMXCFN=+BMXCFN(BMXCID,BMXCFNC)
Begin DoDot:2
+5 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(B(BMXCFN,BMXIEN))
IF BMXIEN=""
QUIT
Begin DoDot:3
+6 SET $PIECE(BMXCFN(BMXCID,BMXCFNC),U,2)=BMXIEN
+7 SET BMXFLD=0
FOR
SET BMXFLD=$ORDER(B(BMXCFN,BMXIEN,BMXFLD))
IF '+BMXFLD
QUIT
Begin DoDot:4
+8 SET BMXINT="D"
FOR
SET BMXINT=$ORDER(B(BMXCFN,BMXIEN,BMXFLD,BMXINT))
IF BMXINT=""
QUIT
Begin DoDot:5
+9 IF '$DATA(BMXFLDOX(BMXCFN,BMXFLD,BMXINT))
QUIT
+10 IF $PIECE(BMXFLDO(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)),U,4)="W"
DO MCWP
QUIT
+11 DO FIXIEN
+12 SET BMXCS="BMXCHAIN("_BMXCID_","_$SELECT($LENGTH(BMXIEN,",")=2:1,1:2)_","_BMXCFIEN_","_BMXFLD_","_$CHAR(34)_BMXINT_$CHAR(34)_")"
+13 SET @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXINT)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
FIXIEN ;
+1 NEW BMXC,BMXCFN1,BMXOFF
+2 SET BMXC=BMXCFNC
+3 SET BMXCFIEN=BMXCFN_","_$PIECE(BMXIEN,",",$LENGTH(BMXIEN,","))
+4 SET BMXOFF=1
+5 FOR
SET BMXC=$ORDER(BMXCFN(BMXCID,BMXC),-1)
IF '+BMXC
QUIT
Begin DoDot:1
+6 SET BMXCFN1=+BMXCFN(BMXCID,BMXC)
+7 IF '$DATA(BMXMFL(BMXCFN,"OTM"))
Begin DoDot:2
+8 IF '$DATA(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN))
QUIT
+9 SET BMXCFIEN=BMXCFN1_","_$PIECE(BMXIEN,",",$LENGTH(BMXIEN,",")-BMXOFF)_","_BMXCFIEN
End DoDot:2
+10 IF $DATA(BMXMFL(BMXCFN,"OTM"))
Begin DoDot:2
+11 IF '$DATA(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN))
QUIT
+12 SET BMXCFIEN=BMXCFN1_$PIECE(BMXCFN(BMXCID,BMXC),U,2)_","_BMXCFIEN
End DoDot:2
+13 SET BMXOFF=BMXOFF+1
End DoDot:1
+14 ;
+15 ;
+16 QUIT
+17 ;
FIXCFN ;
+1 NEW J,K,L
+2 SET J=0
FOR
SET J=$ORDER(BMXCFN(J))
IF '+J
QUIT
Begin DoDot:1
+3 SET K=0
FOR
SET K=$ORDER(BMXCFN(J,K))
IF '+K
QUIT
Begin DoDot:2
+4 SET L=0
FOR
SET L=$ORDER(BMXCFN(J,K,L))
IF '+L
QUIT
Begin DoDot:3
+5 KILL BMXCFN(J,K,L)
+6 SET BMXCFN(J,K)=L
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
MCWP ;
+1 ;MAKEC Process WP Field
+2 NEW BMXIENL,BMXWP
+3 SET BMXIENL=1
+4 IF $LENGTH(BMXIEN,",")>2
SET BMXIENL=2
+5 SET BMXWP=0
+6 ;
+7 FOR
SET BMXWP=$ORDER(B(BMXCFN,BMXIEN,BMXFLD,BMXWP))
IF '+BMXWP
QUIT
Begin DoDot:1
+8 SET BMXCS="BMXCHAIN("_BMXCID_","_BMXIENL_","_BMXCFN_BMXIEN_","_BMXFLD_","_$CHAR(34)_BMXINT_$CHAR(34)_","_BMXWP_")"
+9 SET @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXWP)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)_U_"W"_U_BMXWP
End DoDot:1
+10 QUIT
+11 ;
+12 ;
MAKEB ;
+1 NEW BMXFILE,BMXIEN,BMXFLD,BMXINT
+2 NEW BMXSUB,BMXIENR
+3 SET BMXFILE=0
FOR
SET BMXFILE=$ORDER(A(BMXFILE))
IF '+BMXFILE
QUIT
Begin DoDot:1
+4 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(A(BMXFILE,BMXIEN))
IF '+BMXIEN
QUIT
Begin DoDot:2
+5 SET BMXFLD=0
FOR
SET BMXFLD=$ORDER(A(BMXFILE,BMXIEN,BMXFLD))
IF '+BMXFLD
QUIT
Begin DoDot:3
+6 SET BMXINT=0
FOR
SET BMXINT=$ORDER(A(BMXFILE,BMXIEN,BMXFLD,BMXINT))
IF BMXINT=""
QUIT
Begin DoDot:4
+7 SET BMXIENR=$$REVERSE(BMXIEN)
+8 SET BMXSUB="B("_BMXFILE_","_$CHAR(34)_BMXIENR_$CHAR(34)_","_BMXFLD_","_$CHAR(34)_BMXINT_$CHAR(34)_")"
+9 IF $DATA(BMXFLDOX(BMXFILE,BMXFLD,BMXINT))
IF $PIECE(BMXFLDO(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),U,5)="D"
Begin DoDot:5
+10 SET @BMXSUB=$TRANSLATE(A(BMXFILE,BMXIEN,BMXFLD,BMXINT),"@"," ")
End DoDot:5
QUIT
+11 SET @BMXSUB=A(BMXFILE,BMXIEN,BMXFLD,BMXINT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
REVERSE(BMXIEN) ;
+1 NEW J,T,C
+2 SET C=1
+3 FOR J=$LENGTH(BMXIEN,","):-1:1
Begin DoDot:1
+4 SET $PIECE(T,",",C)=$PIECE(BMXIEN,",",J)
+5 SET C=C+1
End DoDot:1
+6 QUIT T
