- DICLIX0 ;SEA/TOAD,SF/TKW-FileMan: Continuation of DICLIX ;7/31/98 09:03
- ;;22.0;VA FileMan;;Mar 30, 1999;
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- FINDMORE(DISUB,DIVAL,DIPART,DINDEX,DIMORE) ; Look across the numeric/string collation boundary
- ; Searching forwards
- N S,DIOUT S DIOUT=0
- I DINDEX(DISUB,"WAY")=1 D Q
- . I +$P(DIVAL,"E")=DIVAL,DIPART'=0 F D Q:DIOUT!(+$P(DIVAL,"E")'=DIVAL)
- . . I DIPART<DIVAL,((DIPART[".")!(DIPART<0)) S DIVAL=" " Q
- . . D NXT(.DIVAL,DIPART,1,DINDEX(DISUB,"ROOT"),.DIOUT) Q
- . Q:DIOUT
- . S DIMORE=0
- . S S=$O(@DINDEX(DISUB,"ROOT")@(DIPART_" "),-1)
- . S S=$O(@DINDEX(DISUB,"ROOT")@(S))
- . Q:S'=""&(DIVAL]]S) S DIVAL=S Q
- ; Searching backwards
- I +$P(DIVAL,"E")'=DIVAL S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(" "),-1) Q:DIVAL=""
- I DIPART=0 S DIVAL=$S($D(@DINDEX(DISUB,"ROOT")@(0)):0,1:"") Q
- I DIPART>DIVAL,((DIPART[".")!(DIPART>0)) S DIVAL="" Q
- I DIPART<0,DIVAL>DIPART D
- . I $D(@DINDEX(DISUB,"ROOT")@(DIPART)) S DIVAL=DIPART Q
- . S DIVAL=$O(@DINDEX(DISUB,"ROOT")@(DIPART),-1) Q
- Q:$E(DIVAL,1,$L(DIPART))=DIPART!(DIVAL="")
- F D Q:DIOUT!(DIVAL="")
- . I DIPART>DIVAL,((DIPART[".")!(DIPART>0)) S DIVAL="" Q
- . D NXT(.DIVAL,DIPART,-1,DINDEX(DISUB,"ROOT"),.DIOUT) Q
- Q
- NXT(DIVAL,DIPART,DIWAY,DIROOT,DIOUT) ; Skip values we don't need to look at within numeric entries
- N DIPART2,DIVAL2,I,P,V
- S DIPART2=$P(DIPART,"."),DIVAL2=$P(DIVAL,".")
- S P=$S(DIPART<0:-DIPART2,1:DIPART2)
- S V=$S(DIVAL<0:$E(DIVAL2,2,($L(P)+1)),1:$E(DIVAL2,1,$L(P)))
- S I=$L(DIVAL2)
- I DIWAY=1&(DIPART>0)!(DIWAY=-1&(DIPART<0)) D
- . S:V>P I=I+1 Q
- E D
- . S DIPART2=DIPART2+$S(DIPART>0:1,1:-1)
- . I P>V,$L(DIPART2)=$L($P(DIPART,".")) S I=I-1
- S V="",I=I-$L(DIPART2)+1 S:I>1 $P(V,"0",I)=""
- S DIVAL=DIPART2_V
- I $E(DIVAL,1,$L(DIPART))=DIPART,$D(@DINDEX(DISUB,"ROOT")@(DIVAL)) S DIOUT=1 Q
- S DIVAL=$O(@DIROOT@(DIVAL),DIWAY)
- S:$E(DIVAL,1,$L(DIPART))=DIPART DIOUT=1
- Q
- ;
- ;
- DICLIX0 ;SEA/TOAD,SF/TKW-FileMan: Continuation of DICLIX ;7/31/98 09:03
- +1 ;;22.0;VA FileMan;;Mar 30, 1999;
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- FINDMORE(DISUB,DIVAL,DIPART,DINDEX,DIMORE) ; Look across the numeric/string collation boundary
- +1 ; Searching forwards
- +2 NEW S,DIOUT
- SET DIOUT=0
- +3 IF DINDEX(DISUB,"WAY")=1
- Begin DoDot:1
- +4 IF +$PIECE(DIVAL,"E")=DIVAL
- IF DIPART'=0
- FOR
- Begin DoDot:2
- +5 IF DIPART<DIVAL
- IF ((DIPART[".")!(DIPART<0))
- SET DIVAL=" "
- QUIT
- +6 DO NXT(.DIVAL,DIPART,1,DINDEX(DISUB,"ROOT"),.DIOUT)
- QUIT
- End DoDot:2
- IF DIOUT!(+$PIECE(DIVAL,"E")'=DIVAL)
- QUIT
- +7 IF DIOUT
- QUIT
- +8 SET DIMORE=0
- +9 SET S=$ORDER(@DINDEX(DISUB,"ROOT")@(DIPART_" "),-1)
- +10 SET S=$ORDER(@DINDEX(DISUB,"ROOT")@(S))
- +11 IF S'=""&(DIVAL]]S)
- QUIT
- SET DIVAL=S
- QUIT
- End DoDot:1
- QUIT
- +12 ; Searching backwards
- +13 IF +$PIECE(DIVAL,"E")'=DIVAL
- SET DIVAL=$ORDER(@DINDEX(DISUB,"ROOT")@(" "),-1)
- IF DIVAL=""
- QUIT
- +14 IF DIPART=0
- SET DIVAL=$SELECT($DATA(@DINDEX(DISUB,"ROOT")@(0)):0,1:"")
- QUIT
- +15 IF DIPART>DIVAL
- IF ((DIPART[".")!(DIPART>0))
- SET DIVAL=""
- QUIT
- +16 IF DIPART<0
- IF DIVAL>DIPART
- Begin DoDot:1
- +17 IF $DATA(@DINDEX(DISUB,"ROOT")@(DIPART))
- SET DIVAL=DIPART
- QUIT
- +18 SET DIVAL=$ORDER(@DINDEX(DISUB,"ROOT")@(DIPART),-1)
- QUIT
- End DoDot:1
- +19 IF $EXTRACT(DIVAL,1,$LENGTH(DIPART))=DIPART!(DIVAL="")
- QUIT
- +20 FOR
- Begin DoDot:1
- +21 IF DIPART>DIVAL
- IF ((DIPART[".")!(DIPART>0))
- SET DIVAL=""
- QUIT
- +22 DO NXT(.DIVAL,DIPART,-1,DINDEX(DISUB,"ROOT"),.DIOUT)
- QUIT
- End DoDot:1
- IF DIOUT!(DIVAL="")
- QUIT
- +23 QUIT
- NXT(DIVAL,DIPART,DIWAY,DIROOT,DIOUT) ; Skip values we don't need to look at within numeric entries
- +1 NEW DIPART2,DIVAL2,I,P,V
- +2 SET DIPART2=$PIECE(DIPART,".")
- SET DIVAL2=$PIECE(DIVAL,".")
- +3 SET P=$SELECT(DIPART<0:-DIPART2,1:DIPART2)
- +4 SET V=$SELECT(DIVAL<0:$EXTRACT(DIVAL2,2,($LENGTH(P)+1)),1:$EXTRACT(DIVAL2,1,$LENGTH(P)))
- +5 SET I=$LENGTH(DIVAL2)
- +6 IF DIWAY=1&(DIPART>0)!(DIWAY=-1&(DIPART<0))
- Begin DoDot:1
- +7 IF V>P
- SET I=I+1
- QUIT
- End DoDot:1
- +8 IF '$TEST
- Begin DoDot:1
- +9 SET DIPART2=DIPART2+$SELECT(DIPART>0:1,1:-1)
- +10 IF P>V
- IF $LENGTH(DIPART2)=$LENGTH($PIECE(DIPART,"."))
- SET I=I-1
- End DoDot:1
- +11 SET V=""
- SET I=I-$LENGTH(DIPART2)+1
- IF I>1
- SET $PIECE(V,"0",I)=""
- +12 SET DIVAL=DIPART2_V
- +13 IF $EXTRACT(DIVAL,1,$LENGTH(DIPART))=DIPART
- IF $DATA(@DINDEX(DISUB,"ROOT")@(DIVAL))
- SET DIOUT=1
- QUIT
- +14 SET DIVAL=$ORDER(@DIROOT@(DIVAL),DIWAY)
- +15 IF $EXTRACT(DIVAL,1,$LENGTH(DIPART))=DIPART
- SET DIOUT=1
- +16 QUIT
- +17 ;
- +18 ;