- 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
