DICUIX2 ;VEN/TOAD,SF/TKW - Lookup: Build Index Data ;12 DEC 2015
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;
; Contents
;
; COMMON1: Load Data-subscript Data into DINDEX
; $$BACKFROM: Return From Value for Backward Collation
; COMMON2: Load IEN-subscript Data into DINDEX
; DAT: Process FROM and PART for dates
; $$ORDERQ: Is File Like Order File: Dinumed but No B Index?
;
;
COMMON1 ; Load Data-subscript Data into DINDEX
;
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
;
C1 ; 1. Decide which direction to traverse this subscript
;
S DINDEX(DISUB,"WAY")=DIWAY*DINDEX("WAY") ; calculate direction
I DIFLAGS[4,DIFLAGS'["l" S DINDEX(DISUB,"WAY")=1 ; override?
I $G(DINDEX("WAY","REVERSE")) S DITO(DISUB)=DIFR,DIFR=""
;
C2 ; 2. Adjust From & To to fit max subscript length
;
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)
;
C3 ; 3. Build code to extract indexed field from data
;
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)
S DINDEX(DISUB,"GET")="DIVAL="_DICODE
;
C4 ; 4. Find & record subscript data-type info
;
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: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)
. . S DINDEX("AT")=2
;
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)_")"
;
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_","
;
C5 ; 5. Set Any More?
;
S DINDEX(DISUB,"MORE?")=0
I +$P(DIPRT,"E")=DIPRT,DITYPE'["D" D
. ;
. Q:DIFLAGS["X" ; no partial-numeric matches if require exact
. N PNM S PNM=0 ; suppress PNM for pointers or variable pointers?
. I DITYPE["V"!(DITYPE["P") D Q:'PNM ; at least for these cases:
. . I DIFLAGS["l",DIC(0)["U" Q ; classic, untransformed lookup
. . I DIFLAGS[3,DIFLAGS["Q" Q ; Lister, quick list
. . I DIFLAGS[4,DIFLAGS["Q" Q ; Finder, quick lookup
. . S PNM=1 ; otherwise, allow it on ptrs or vptrs
. ;
. I DINDEX(DISUB,"WAY")=-1 S DINDEX(DISUB,"MORE?")=1 Q
. I +$P(DIFR,"E")=DIFR!(DIFR="") S DINDEX(DISUB,"MORE?")=1
;
C6 ; 6. Handle partial matches, incl. setting From
;
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:$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:"")
. ;
. 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=$$BACKFROM(DIPRT) ; start from end of partial matches
;
S (DINDEX(DISUB),DINDEX(DISUB,"FROM"))=DIFR
I DIPRT]"" S DINDEX(DISUB,"PART")=DIPRT
I $D(DITO(DISUB)) S DINDEX(DISUB,"TO")=DITO(DISUB)
;
C7 ; 7. Handle subscripts with data-type transforms
;
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
. S DINDEX(DISUB,"GETEXT")=DIGET
;
QUIT ; end of COMMON1
;
;
BACKFROM(DIPART) ; Return From Value for Backward Collation
;
;;private;function;clean;silent;SAC compliant
; input: DIPART = the partial-match value
; output = From value for backward collation
; called by:
; COMMON1, at C6+18
; BACKFROM^DICF1
; calls: none
;
N DIFROM S DIFROM=DIPART_"{{{{{{{{{{"
;
QUIT DIFROM ; return From value ; end of $$BACKFROM
;
;
COMMON2 ; Load IEN-subscript Data into DINDEX
;
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")
;
QUIT ; end of COMMON2
;
;
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
;
QUIT ; end of DAT
;
;
ORDERQ(FILENUM) ; Is File Like Order File: Dinumed but No B Index?
;
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
;
QUIT 0 ; end of $$ORDERQ
;
;
EOR ; end of routine DICUIX2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICUIX2 6790 printed Oct 16, 2024@18:47:18 Page 2
DICUIX2 ;VEN/TOAD,SF/TKW - Lookup: Build Index Data ;12 DEC 2015
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;
+8 ; Contents
+9 ;
+10 ; COMMON1: Load Data-subscript Data into DINDEX
+11 ; $$BACKFROM: Return From Value for Backward Collation
+12 ; COMMON2: Load IEN-subscript Data into DINDEX
+13 ; DAT: Process FROM and PART for dates
+14 ; $$ORDERQ: Is File Like Order File: Dinumed but No B Index?
+15 ;
+16 ;
COMMON1 ; Load Data-subscript Data into DINDEX
+1 ;
+2 NEW DIFR,DIPRT
+3 SET DIFR=$GET(DIFROM(DISUB))
SET DIPRT=$GET(DIPART(DISUB))
+4 IF DINDEX(DISUB,"FILE")=DIFILE
SET DINDEX("FLIST")=DINDEX("FLIST")_"^"_DINDEX(DISUB,"FIELD")
+5 IF DIFLAGS["q"
DO C3
QUIT
+6 SET DINDEX(DISUB,"USE")=0
Begin DoDot:1
+7 IF DIFROM("IEN")
SET DINDEX(DISUB,"USE")=1
QUIT
+8 if $GET(DIFROM(DISUB+1))]""
SET DINDEX(DISUB,"USE")=1
End DoDot:1
+9 ;
C1 ; 1. Decide which direction to traverse this subscript
+1 ;
+2 ; calculate direction
SET DINDEX(DISUB,"WAY")=DIWAY*DINDEX("WAY")
+3 ; override?
IF DIFLAGS[4
IF DIFLAGS'["l"
SET DINDEX(DISUB,"WAY")=1
+4 IF $GET(DINDEX("WAY","REVERSE"))
SET DITO(DISUB)=DIFR
SET DIFR=""
+5 ;
C2 ; 2. Adjust From & To to fit max subscript length
+1 ;
+2 IF DIFLAGS[4
SET DINDEX(DISUB,"LENGTH")=DILENGTH
+3 IF DIFLAGS[3
Begin DoDot:1
+4 SET DIFR=$EXTRACT(DIFR,1,DILENGTH)
+5 SET DIPRT=$EXTRACT(DIPRT,1,DILENGTH)
+6 IF $DATA(DITO(DISUB))
SET DITO(DISUB)=$EXTRACT(DITO(DISUB),1,DILENGTH)
End DoDot:1
+7 ;
C3 ; 3. Build code to extract indexed field from data
+1 ;
+2 IF 'DINDEX(DISUB,"FILE")!('DINDEX(DISUB,"FIELD"))
SET DINODE=""
SET DICODE="DINDEX(DISUB)"
+3 IF '$TEST
DO GET^DICUIX1(DIFILE,DINDEX(DISUB,"FILE"),DINDEX(DISUB,"FIELD"),.DINODE,.DICODE)
+4 IF $GET(DIERR)
Begin DoDot:1
+5 SET DINODE=""
SET DICODE="DINDEX(DISUB)"
+6 DO BLD^DIALOG(8099,DINDEX)
End DoDot:1
+7 SET DINDEX(DISUB,"GET")="DIVAL="_DICODE
+8 ;
C4 ; 4. Find & record subscript data-type info
+1 ;
+2 SET DITYPE=$PIECE(DINODE,U,2)
+3 NEW %
SET %="F"
Begin DoDot:1
+4 if DIFLAGS["Q"
QUIT
+5 ;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
+6 IF DITYPE["D"
SET %="D"
QUIT
+7 IF DITYPE["S"
SET %="S"
QUIT
+8 IF DITYPE["V"
SET %="V"
QUIT
+9 IF DITYPE["N"
SET %="N"
End DoDot:1
SET DINDEX(DISUB,"TYPE")=%
+10 ;
+11 if DIFLAGS["q"
QUIT
+12 IF DISUB=1
Begin DoDot:1
+13 SET DITEMP=$SELECT($DATA(DIFILE(DIFILE,"NO B")):DIFILE(DIFILE,"NO B"),1:DIFILE(DIFILE,"O")_"DINDEX")
+14 IF "VP"[DINDEX(DISUB,"TYPE")
Begin DoDot:2
+15 SET DINDEX(1,"NODE")=DINODE
if DIFLAGS[4
QUIT
+16 IF DIFLAGS'["Q"
IF $$CHKP^DICUIX1(.DIFILE,.DINDEX,+$GET(DINUMBER),DIFR_DIPRT,.DISCREEN)
Begin DoDot:3
+17 DO TMPIDX^DICUIX1(1,.DITEMP,.DITEMP2,.DINDEX)
End DoDot:3
QUIT
+18 SET DINDEX("AT")=2
End DoDot:2
End DoDot:1
+19 ;
+20 IF DISUB>1
Begin DoDot:1
+21 IF DIFLAGS[4
IF "VP"[DINDEX(DISUB,"TYPE")
SET DINDEX(DISUB,"GET")="DIVAL=$G(DINDEX(DISUB,""EXT""))"
+22 IF DIFLAGS[3
IF "VP"[DINDEX(DISUB,"TYPE")
IF DIFLAGS'["Q"
IF '$DATA(DINDEX("ROOTCNG"))
DO TMPIDX^DICUIX1(DISUB,.DITEMP,.DITEMP2,.DINDEX)
QUIT
+23 SET DITEMP=DITEMP_"DINDEX("_(DISUB-1)_")"
End DoDot:1
+24 ;
+25 SET DINDEX(DISUB,"ROOT")=DITEMP_")"
SET DITEMP=DITEMP_","
+26 IF $DATA(DITEMP2)
Begin DoDot:1
+27 if DISUB>1
SET DITEMP2=DITEMP2_"DIX("_(DISUB-1)_")"
+28 SET DINDEX(DISUB,"IXROOT")=DITEMP2_")"
SET DITEMP2=DITEMP2_","
End DoDot:1
+29 ;
C5 ; 5. Set Any More?
+1 ;
+2 SET DINDEX(DISUB,"MORE?")=0
+3 IF +$PIECE(DIPRT,"E")=DIPRT
IF DITYPE'["D"
Begin DoDot:1
+4 ;
+5 ; no partial-numeric matches if require exact
if DIFLAGS["X"
QUIT
+6 ; suppress PNM for pointers or variable pointers?
NEW PNM
SET PNM=0
+7 ; at least for these cases:
IF DITYPE["V"!(DITYPE["P")
Begin DoDot:2
+8 ; classic, untransformed lookup
IF DIFLAGS["l"
IF DIC(0)["U"
QUIT
+9 ; Lister, quick list
IF DIFLAGS[3
IF DIFLAGS["Q"
QUIT
+10 ; Finder, quick lookup
IF DIFLAGS[4
IF DIFLAGS["Q"
QUIT
+11 ; otherwise, allow it on ptrs or vptrs
SET PNM=1
End DoDot:2
if 'PNM
QUIT
+12 ;
+13 IF DINDEX(DISUB,"WAY")=-1
SET DINDEX(DISUB,"MORE?")=1
QUIT
+14 IF +$PIECE(DIFR,"E")=DIFR!(DIFR="")
SET DINDEX(DISUB,"MORE?")=1
End DoDot:1
+15 ;
C6 ; 6. Handle partial matches, incl. setting From
+1 ;
+2 IF DIPRT]""
Begin DoDot:1
+3 IF DIFLAGS[4
IF "VP"[DINDEX(DISUB,"TYPE")
if DIFLAGS'["l"
QUIT
if DISUB>1
QUIT
+4 IF DITYPE["D"
IF DIFLAGS[3
Begin DoDot:2
+5 NEW I
SET I=$SELECT(DINDEX(DISUB,"WAY")=1:"0000000",1:9999999)
+6 DO DAT(.DIFR,DIPRT,I,DINDEX(DISUB,"WAY"),.DIOUT)
End DoDot:2
QUIT
+7 if $EXTRACT(DIFR,1,$LENGTH(DIPRT))=DIPRT
QUIT
+8 IF DINDEX(DISUB,"WAY")=1
Begin DoDot:2
+9 IF DIFR]](DIPRT_$SELECT(+$PIECE(DIPRT,"E")=DIPRT:" ",1:""))
SET DIOUT=1
QUIT
+10 IF +$PIECE(DIPRT,"E")=DIPRT
IF DIPRT<0
SET DIFR=$SELECT(DIPRT[".":$PIECE(DIPRT,".")-1,1:"")
QUIT
+11 IF +$PIECE(DIPRT,"E")=DIPRT
IF +$PIECE(DIFR,"E")=DIFR
IF DIFR>DIPRT
QUIT
+12 SET DINDEX(DISUB,"USE")=1
+13 SET DIFR=DIPRT_$SELECT(+$PIECE(DIPRT,"E")'=DIPRT:"",DIFR]]DIPRT:" ",1:"")
End DoDot:2
QUIT
+14 ;
+15 IF DIFR'=""
IF DIPRT]]DIFR
SET DIOUT=1
QUIT
+16 IF +$PIECE(DIPRT,"E")=DIPRT
IF DIFR?.1"-"1.N.E
QUIT
+17 SET DINDEX(DISUB,"USE")=1
+18 ; start from end of partial matches
SET DIFR=$$BACKFROM(DIPRT)
End DoDot:1
+19 ;
+20 SET (DINDEX(DISUB),DINDEX(DISUB,"FROM"))=DIFR
+21 IF DIPRT]""
SET DINDEX(DISUB,"PART")=DIPRT
+22 IF $DATA(DITO(DISUB))
SET DINDEX(DISUB,"TO")=DITO(DISUB)
+23 ;
C7 ; 7. Handle subscripts with data-type transforms
+1 ;
+2 IF $GET(DIDENT(-5))
Begin DoDot:1
+3 IF $DATA(DINDEX(DISUB,"TRANOUT"))
SET DINDEX(DISUB,"GETEXT")=DIGET
QUIT
+4 NEW T
SET T=DITYPE
IF T'["D"
IF T'["S"
IF T'["P"
IF T'["V"
IF T'["O"
QUIT
+5 IF DIFLAGS[3
IF "PV"[DINDEX(DISUB,"TYPE")
IF (DISUB>1!($DATA(DINDEX("ROOTCNG",1))))
Begin DoDot:2
+6 IF DINDEX(DISUB,"FILE")'=DIFILE
SET DIGET=0
QUIT
+7 SET DIGET=2
End DoDot:2
+8 SET DINDEX(DISUB,"GETEXT")=DIGET
End DoDot:1
+9 ;
+10 ; end of COMMON1
QUIT
+11 ;
+12 ;
BACKFROM(DIPART) ; Return From Value for Backward Collation
+1 ;
+2 ;;private;function;clean;silent;SAC compliant
+3 ; input: DIPART = the partial-match value
+4 ; output = From value for backward collation
+5 ; called by:
+6 ; COMMON1, at C6+18
+7 ; BACKFROM^DICF1
+8 ; calls: none
+9 ;
+10 NEW DIFROM
SET DIFROM=DIPART_"{{{{{{{{{{"
+11 ;
+12 ; return From value ; end of $$BACKFROM
QUIT DIFROM
+13 ;
+14 ;
COMMON2 ; Load IEN-subscript Data into DINDEX
+1 ;
+2 NEW DIEN
SET DIEN=DINDEX("#")+1
+3 if DINDEX'="#"
SET DINDEX(DIEN,"ROOT")=DITEMP_"DINDEX("_(DIEN-1)_"))"
+4 IF $DATA(DITEMP2)
SET DINDEX(DIEN,"IXROOT")=DITEMP2_"DIX("_(DIEN-1)_"))"
+5 IF $GET(DINDEX("WAY","REVERSE"))
IF DIFROM("IEN")
SET DINDEX(DIEN,"TO")=DIFROM("IEN")
SET DIFROM("IEN")=""
+6 SET DINDEX(DIEN)=DIFROM("IEN")
+7 IF DINDEX(DIEN)=0
IF DINDEX("WAY")=-1
SET DINDEX(DIEN)=""
+8 IF DIFROM("IEN")
SET DINDEX(DIEN,"FROM")=DIFROM("IEN")
+9 SET DINDEX(DIEN,"WAY")=DINDEX("WAY")
+10 ;
+11 ; end of COMMON2
QUIT
+12 ;
+13 ;
DAT(DIFR,DIPRT,DIAPP,DIWAY,DIOUT) ; Process FROM and PART for dates
+1 ;
+2 NEW L,P,DIPART
SET L=$LENGTH(DIFR)
SET P=$LENGTH(DIPRT)
SET DIPART=DIPRT
+3 IF L<P
SET DIFR=DIFR_$EXTRACT(DIPART,L+1,P)
+4 IF $LENGTH(DIFR)<7
SET DIFR=$EXTRACT(DIFR_DIAPP,1,7)
+5 if $EXTRACT(DIFR,1,P)=DIPART
QUIT
+6 IF P<7
SET DIPART=$EXTRACT(DIPART_DIAPP,1,7)
+7 IF DIWAY=1
IF DIFR]]DIPART
SET DIOUT=1
QUIT
+8 IF DIWAY=-1
IF DIPART]]DIFR
SET DIOUT=1
QUIT
+9 SET $EXTRACT(DIFR,1,P)=DIPRT
+10 SET DINDEX(DISUB,"USE")=1
+11 ;
+12 ; end of DAT
QUIT
+13 ;
+14 ;
ORDERQ(FILENUM) ; Is File Like Order File: Dinumed but No B Index?
+1 ;
+2 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
+3 ;
+4 ; end of $$ORDERQ
QUIT 0
+5 ;
+6 ;
EOR ; end of routine DICUIX2
