DICUIX2 ;SEA/TOAD,SF/TKW-FileMan: Build index data in DINDEX array (cont). ;02/28/2012
;;22.0;VA FileMan;**4,28,67,168**;Mar 30, 1999;Build 27
;Per VHA Directive 2004-038, this routine should not be modified.
;
COMMON1 ; Put info about data subscripts into DINDEX array
N DIFR,DIPRT
S DIFR=$G(DIFROM(DISUB)),DIPRT=$G(DIPART(DISUB))
I DINDEX(DISUB,"FILE")=DIFILE S DINDEX("FLIST")=DINDEX("FLIST")_"^"_DINDEX(DISUB,"FIELD")
I DIFLAGS["q" D C3 Q
S DINDEX(DISUB,"USE")=0 D
. I DIFROM("IEN") S DINDEX(DISUB,"USE")=1 Q
. S:$G(DIFROM(DISUB+1))]"" DINDEX(DISUB,"USE")=1 Q
C1 S DINDEX(DISUB,"WAY")=$S(DIFLAGS[4:1,DIWAY=DINDEX("WAY"):1,1:-1)
I $G(DINDEX("WAY","REVERSE")) S DITO(DISUB)=DIFR,DIFR=""
C2 I DIFLAGS[4 S DINDEX(DISUB,"LENGTH")=DILENGTH
I DIFLAGS[3 D
. S DIFR=$E(DIFR,1,DILENGTH)
. S DIPRT=$E(DIPRT,1,DILENGTH)
. I $D(DITO(DISUB)) S DITO(DISUB)=$E(DITO(DISUB),1,DILENGTH)
. Q
C3 I 'DINDEX(DISUB,"FILE")!('DINDEX(DISUB,"FIELD")) S DINODE="",DICODE="DINDEX(DISUB)"
E D GET^DICUIX1(DIFILE,DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),.DINODE,.DICODE)
I $G(DIERR) D
. S DINODE="",DICODE="DINDEX(DISUB)"
. D BLD^DIALOG(8099,DINDEX) Q
S DINDEX(DISUB,"GET")="DIVAL="_DICODE
C4 S DITYPE=$P(DINODE,U,2)
N % S %="F" D S DINDEX(DISUB,"TYPE")=%
. Q:DIFLAGS["Q"
. I DITYPE["P" S %="P" S:$$ORDERQ(+$P(DITYPE,"P",2)) %="F",DITYPE="F" Q ;TRICK: TREAT FILE 100 POINTERS AS FREE-TEXT!
. I DITYPE["D" S %="D" Q
. I DITYPE["S" S %="S" Q
. I DITYPE["V" S %="V" Q
. I DITYPE["N" S %="N"
. Q
Q:DIFLAGS["q"
I DISUB=1 D
. S DITEMP=$S($D(DIFILE(DIFILE,"NO B")):DIFILE(DIFILE,"NO B"),1:DIFILE(DIFILE,"O")_"DINDEX")
. I "VP"[DINDEX(DISUB,"TYPE") D
. . S DINDEX(1,"NODE")=DINODE Q:DIFLAGS[4
. . I DIFLAGS'["Q",$$CHKP^DICUIX1(.DIFILE,.DINDEX,+$G(DINUMBER),DIFR_DIPRT,.DISCREEN) D Q
. . . D TMPIDX^DICUIX1(1,.DITEMP,.DITEMP2,.DINDEX) Q
. . S DINDEX("AT")=2 Q
. Q
I DISUB>1 D
. I DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") S DINDEX(DISUB,"GET")="DIVAL=$G(DINDEX(DISUB,""EXT""))"
. I DIFLAGS[3,"VP"[DINDEX(DISUB,"TYPE"),DIFLAGS'["Q",'$D(DINDEX("ROOTCNG")) D TMPIDX^DICUIX1(DISUB,.DITEMP,.DITEMP2,.DINDEX) Q
. S DITEMP=DITEMP_"DINDEX("_(DISUB-1)_")"
. Q
S DINDEX(DISUB,"ROOT")=DITEMP_")",DITEMP=DITEMP_","
I $D(DITEMP2) D
. S:DISUB>1 DITEMP2=DITEMP2_"DIX("_(DISUB-1)_")"
. S DINDEX(DISUB,"IXROOT")=DITEMP2_")",DITEMP2=DITEMP2_","
. Q
C5 S DINDEX(DISUB,"MORE?")=0
I +$P(DIPRT,"E")=DIPRT,DITYPE'["D" D
. I DINDEX(DISUB,"WAY")=-1 S DINDEX(DISUB,"MORE?")=1 Q
. I +$P(DIFR,"E")=DIFR!(DIFR="") S DINDEX(DISUB,"MORE?")=1
. Q
C6 I DIPRT]"" D
. I DIFLAGS[4,"VP"[DINDEX(DISUB,"TYPE") Q:DIFLAGS'["l" Q:DISUB>1
. I DITYPE["D",DIFLAGS[3 D Q
. . N I S I=$S(DINDEX(DISUB,"WAY")=1:"0000000",1:9999999)
. . D DAT(.DIFR,DIPRT,I,DINDEX(DISUB,"WAY"),.DIOUT) Q
. Q:$E(DIFR,1,$L(DIPRT))=DIPRT
. I DINDEX(DISUB,"WAY")=1 D Q
. . I DIFR]](DIPRT_$S(+$P(DIPRT,"E")=DIPRT:" ",1:"")) S DIOUT=1 Q
. . I +$P(DIPRT,"E")=DIPRT,DIPRT<0 S DIFR=$S(DIPRT[".":$P(DIPRT,".")-1,1:"") Q
. . I +$P(DIPRT,"E")=DIPRT,+$P(DIFR,"E")=DIFR,DIFR>DIPRT Q
. . S DINDEX(DISUB,"USE")=1
. . S DIFR=DIPRT_$S(+$P(DIPRT,"E")'=DIPRT:"",DIFR]]DIPRT:" ",1:"")
. . Q
. I DIFR'="",DIPRT]]DIFR S DIOUT=1 Q
. I +$P(DIPRT,"E")=DIPRT,DIFR?.1"-"1.N.E Q
. S DINDEX(DISUB,"USE")=1
. S DIFR=DIPRT_"{{{{{{{{{{"
. Q
S DINDEX(DISUB)=$G(DIFR) I DIFR]"" S DINDEX(DISUB,"FROM")=DIFR
I DIPRT]"" S DINDEX(DISUB,"PART")=DIPRT
I $D(DITO(DISUB)) S DINDEX(DISUB,"TO")=DITO(DISUB)
C7 I $G(DIDENT(-5)) D
. I $D(DINDEX(DISUB,"TRANOUT")) S DINDEX(DISUB,"GETEXT")=DIGET Q
. N T S T=DITYPE I T'["D",T'["S",T'["P",T'["V",T'["O" Q
. I DIFLAGS[3,"PV"[DINDEX(DISUB,"TYPE"),(DISUB>1!($D(DINDEX("ROOTCNG",1)))) D
. . I DINDEX(DISUB,"FILE")'=DIFILE S DIGET=0 Q
. . S DIGET=2 Q
. S DINDEX(DISUB,"GETEXT")=DIGET Q
Q
;
COMMON2 ; Put data about IEN subscript into DINDEX array.
N DIEN S DIEN=DINDEX("#")+1
S:DINDEX'="#" DINDEX(DIEN,"ROOT")=DITEMP_"DINDEX("_(DIEN-1)_"))"
I $D(DITEMP2) S DINDEX(DIEN,"IXROOT")=DITEMP2_"DIX("_(DIEN-1)_"))"
I $G(DINDEX("WAY","REVERSE")),DIFROM("IEN") S DINDEX(DIEN,"TO")=DIFROM("IEN"),DIFROM("IEN")=""
S DINDEX(DIEN)=DIFROM("IEN")
I DINDEX(DIEN)=0,DINDEX("WAY")=-1 S DINDEX(DIEN)=""
I DIFROM("IEN") S DINDEX(DIEN,"FROM")=DIFROM("IEN")
S DINDEX(DIEN,"WAY")=DINDEX("WAY")
Q
;
DAT(DIFR,DIPRT,DIAPP,DIWAY,DIOUT) ; Process FROM and PART for dates
N L,P,DIPART S L=$L(DIFR),P=$L(DIPRT),DIPART=DIPRT
I L<P S DIFR=DIFR_$E(DIPART,L+1,P)
I $L(DIFR)<7 S DIFR=$E(DIFR_DIAPP,1,7)
Q:$E(DIFR,1,P)=DIPART
I P<7 S DIPART=$E(DIPART_DIAPP,1,7)
I DIWAY=1,DIFR]]DIPART S DIOUT=1 Q
I DIWAY=-1,DIPART]]DIFR S DIOUT=1 Q
S $E(DIFR,1,P)=DIPRT
S DINDEX(DISUB,"USE")=1
Q
;
ORDERQ(FILENUM) ;IS FILE LIKE ORDER FILE, DINUMED BUT NO CROSS-REF?
I $P($G(^DD(+FILENUM,.01,0)),U,5,99)["DINUM=X",$P(^(0),U,2)'["P",$P(^(0),U,2)'["D",'$D(^DD(+FILENUM,0,"IX","B")) Q 1
Q 0
DICUIX2 ;SEA/TOAD,SF/TKW-FileMan: Build index data in DINDEX array (cont). ;02/28/2012
+1 ;;22.0;VA FileMan;**4,28,67,168**;Mar 30, 1999;Build 27
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
COMMON1 ; Put info about data subscripts into DINDEX array
+1 NEW DIFR,DIPRT
+2 SET DIFR=$GET(DIFROM(DISUB))
SET DIPRT=$GET(DIPART(DISUB))
+3 IF DINDEX(DISUB,"FILE")=DIFILE
SET DINDEX("FLIST")=DINDEX("FLIST")_"^"_DINDEX(DISUB,"FIELD")
+4 IF DIFLAGS["q"
DO C3
QUIT
+5 SET DINDEX(DISUB,"USE")=0
Begin DoDot:1
+6 IF DIFROM("IEN")
SET DINDEX(DISUB,"USE")=1
QUIT
+7 IF $GET(DIFROM(DISUB+1))]""
SET DINDEX(DISUB,"USE")=1
QUIT
End DoDot:1
C1 SET DINDEX(DISUB,"WAY")=$SELECT(DIFLAGS[4:1,DIWAY=DINDEX("WAY"):1,1:-1)
+1 IF $GET(DINDEX("WAY","REVERSE"))
SET DITO(DISUB)=DIFR
SET DIFR=""
C2 IF DIFLAGS[4
SET DINDEX(DISUB,"LENGTH")=DILENGTH
+1 IF DIFLAGS[3
Begin DoDot:1
+2 SET DIFR=$EXTRACT(DIFR,1,DILENGTH)
+3 SET DIPRT=$EXTRACT(DIPRT,1,DILENGTH)
+4 IF $DATA(DITO(DISUB))
SET DITO(DISUB)=$EXTRACT(DITO(DISUB),1,DILENGTH)
+5 QUIT
End DoDot:1
C3 IF 'DINDEX(DISUB,"FILE")!('DINDEX(DISUB,"FIELD"))
SET DINODE=""
SET DICODE="DINDEX(DISUB)"
+1 IF '$TEST
DO GET^DICUIX1(DIFILE,DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),.DINODE,.DICODE)
+2 IF $GET(DIERR)
Begin DoDot:1
+3 SET DINODE=""
SET DICODE="DINDEX(DISUB)"
+4 DO BLD^DIALOG(8099,DINDEX)
QUIT
End DoDot:1
+5 SET DINDEX(DISUB,"GET")="DIVAL="_DICODE
C4 SET DITYPE=$PIECE(DINODE,U,2)
+1 NEW %
SET %="F"
Begin DoDot:1
+2 IF DIFLAGS["Q"
QUIT
+3 ;TRICK: TREAT FILE 100 POINTERS AS FREE-TEXT!
IF DITYPE["P"
SET %="P"
IF $$ORDERQ(+$PIECE(DITYPE,"P",2))
SET %="F"
SET DITYPE="F"
QUIT
+4 IF DITYPE["D"
SET %="D"
QUIT
+5 IF DITYPE["S"
SET %="S"
QUIT
+6 IF DITYPE["V"
SET %="V"
QUIT
+7 IF DITYPE["N"
SET %="N"
+8 QUIT
End DoDot:1
SET DINDEX(DISUB,"TYPE")=%
+9 IF DIFLAGS["q"
QUIT
+10 IF DISUB=1
Begin DoDot:1
+11 SET DITEMP=$SELECT($DATA(DIFILE(DIFILE,"NO B")):DIFILE(DIFILE,"NO B"),1:DIFILE(DIFILE,"O")_"DINDEX")
+12 IF "VP"[DINDEX(DISUB,"TYPE")
Begin DoDot:2
+13 SET DINDEX(1,"NODE")=DINODE
IF DIFLAGS[4
QUIT
+14 IF DIFLAGS'["Q"
IF $$CHKP^DICUIX1(.DIFILE,.DINDEX,+$GET(DINUMBER),DIFR_DIPRT,.DISCREEN)
Begin DoDot:3
+15 DO TMPIDX^DICUIX1(1,.DITEMP,.DITEMP2,.DINDEX)
QUIT
End DoDot:3
QUIT
+16 SET DINDEX("AT")=2
QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF DISUB>1
Begin DoDot:1
+19 IF DIFLAGS[4
IF "VP"[DINDEX(DISUB,"TYPE")
SET DINDEX(DISUB,"GET")="DIVAL=$G(DINDEX(DISUB,""EXT""))"
+20 IF DIFLAGS[3
IF "VP"[DINDEX(DISUB,"TYPE")
IF DIFLAGS'["Q"
IF '$DATA(DINDEX("ROOTCNG"))
DO TMPIDX^DICUIX1(DISUB,.DITEMP,.DITEMP2,.DINDEX)
QUIT
+21 SET DITEMP=DITEMP_"DINDEX("_(DISUB-1)_")"
+22 QUIT
End DoDot:1
+23 SET DINDEX(DISUB,"ROOT")=DITEMP_")"
SET DITEMP=DITEMP_","
+24 IF $DATA(DITEMP2)
Begin DoDot:1
+25 IF DISUB>1
SET DITEMP2=DITEMP2_"DIX("_(DISUB-1)_")"
+26 SET DINDEX(DISUB,"IXROOT")=DITEMP2_")"
SET DITEMP2=DITEMP2_","
+27 QUIT
End DoDot:1
C5 SET DINDEX(DISUB,"MORE?")=0
+1 IF +$PIECE(DIPRT,"E")=DIPRT
IF DITYPE'["D"
Begin DoDot:1
+2 IF DINDEX(DISUB,"WAY")=-1
SET DINDEX(DISUB,"MORE?")=1
QUIT
+3 IF +$PIECE(DIFR,"E")=DIFR!(DIFR="")
SET DINDEX(DISUB,"MORE?")=1
+4 QUIT
End DoDot:1
C6 IF DIPRT]""
Begin DoDot:1
+1 IF DIFLAGS[4
IF "VP"[DINDEX(DISUB,"TYPE")
IF DIFLAGS'["l"
QUIT
IF DISUB>1
QUIT
+2 IF DITYPE["D"
IF DIFLAGS[3
Begin DoDot:2
+3 NEW I
SET I=$SELECT(DINDEX(DISUB,"WAY")=1:"0000000",1:9999999)
+4 DO DAT(.DIFR,DIPRT,I,DINDEX(DISUB,"WAY"),.DIOUT)
QUIT
End DoDot:2
QUIT
+5 IF $EXTRACT(DIFR,1,$LENGTH(DIPRT))=DIPRT
QUIT
+6 IF DINDEX(DISUB,"WAY")=1
Begin DoDot:2
+7 IF DIFR]](DIPRT_$SELECT(+$PIECE(DIPRT,"E")=DIPRT:" ",1:""))
SET DIOUT=1
QUIT
+8 IF +$PIECE(DIPRT,"E")=DIPRT
IF DIPRT<0
SET DIFR=$SELECT(DIPRT[".":$PIECE(DIPRT,".")-1,1:"")
QUIT
+9 IF +$PIECE(DIPRT,"E")=DIPRT
IF +$PIECE(DIFR,"E")=DIFR
IF DIFR>DIPRT
QUIT
+10 SET DINDEX(DISUB,"USE")=1
+11 SET DIFR=DIPRT_$SELECT(+$PIECE(DIPRT,"E")'=DIPRT:"",DIFR]]DIPRT:" ",1:"")
+12 QUIT
End DoDot:2
QUIT
+13 IF DIFR'=""
IF DIPRT]]DIFR
SET DIOUT=1
QUIT
+14 IF +$PIECE(DIPRT,"E")=DIPRT
IF DIFR?.1"-"1.N.E
QUIT
+15 SET DINDEX(DISUB,"USE")=1
+16 SET DIFR=DIPRT_"{{{{{{{{{{"
+17 QUIT
End DoDot:1
+18 SET DINDEX(DISUB)=$GET(DIFR)
IF DIFR]""
SET DINDEX(DISUB,"FROM")=DIFR
+19 IF DIPRT]""
SET DINDEX(DISUB,"PART")=DIPRT
+20 IF $DATA(DITO(DISUB))
SET DINDEX(DISUB,"TO")=DITO(DISUB)
C7 IF $GET(DIDENT(-5))
Begin DoDot:1
+1 IF $DATA(DINDEX(DISUB,"TRANOUT"))
SET DINDEX(DISUB,"GETEXT")=DIGET
QUIT
+2 NEW T
SET T=DITYPE
IF T'["D"
IF T'["S"
IF T'["P"
IF T'["V"
IF T'["O"
QUIT
+3 IF DIFLAGS[3
IF "PV"[DINDEX(DISUB,"TYPE")
IF (DISUB>1!($DATA(DINDEX("ROOTCNG",1))))
Begin DoDot:2
+4 IF DINDEX(DISUB,"FILE")'=DIFILE
SET DIGET=0
QUIT
+5 SET DIGET=2
QUIT
End DoDot:2
+6 SET DINDEX(DISUB,"GETEXT")=DIGET
QUIT
End DoDot:1
+7 QUIT
+8 ;
COMMON2 ; Put data about IEN subscript into DINDEX array.
+1 NEW DIEN
SET DIEN=DINDEX("#")+1
+2 IF DINDEX'="#"
SET DINDEX(DIEN,"ROOT")=DITEMP_"DINDEX("_(DIEN-1)_"))"
+3 IF $DATA(DITEMP2)
SET DINDEX(DIEN,"IXROOT")=DITEMP2_"DIX("_(DIEN-1)_"))"
+4 IF $GET(DINDEX("WAY","REVERSE"))
IF DIFROM("IEN")
SET DINDEX(DIEN,"TO")=DIFROM("IEN")
SET DIFROM("IEN")=""
+5 SET DINDEX(DIEN)=DIFROM("IEN")
+6 IF DINDEX(DIEN)=0
IF DINDEX("WAY")=-1
SET DINDEX(DIEN)=""
+7 IF DIFROM("IEN")
SET DINDEX(DIEN,"FROM")=DIFROM("IEN")
+8 SET DINDEX(DIEN,"WAY")=DINDEX("WAY")
+9 QUIT
+10 ;
DAT(DIFR,DIPRT,DIAPP,DIWAY,DIOUT) ; Process FROM and PART for dates
+1 NEW L,P,DIPART
SET L=$LENGTH(DIFR)
SET P=$LENGTH(DIPRT)
SET DIPART=DIPRT
+2 IF L<P
SET DIFR=DIFR_$EXTRACT(DIPART,L+1,P)
+3 IF $LENGTH(DIFR)<7
SET DIFR=$EXTRACT(DIFR_DIAPP,1,7)
+4 IF $EXTRACT(DIFR,1,P)=DIPART
QUIT
+5 IF P<7
SET DIPART=$EXTRACT(DIPART_DIAPP,1,7)
+6 IF DIWAY=1
IF DIFR]]DIPART
SET DIOUT=1
QUIT
+7 IF DIWAY=-1
IF DIPART]]DIFR
SET DIOUT=1
QUIT
+8 SET $EXTRACT(DIFR,1,P)=DIPRT
+9 SET DINDEX(DISUB,"USE")=1
+10 QUIT
+11 ;
ORDERQ(FILENUM) ;IS FILE LIKE ORDER FILE, DINUMED BUT NO CROSS-REF?
+1 IF $PIECE($GET(^DD(+FILENUM,.01,0)),U,5,99)["DINUM=X"
IF $PIECE(^(0),U,2)'["P"
IF $PIECE(^(0),U,2)'["D"
IF '$DATA(^DD(+FILENUM,0,"IX","B"))
QUIT 1
+2 QUIT 0
