DICLIX0 ;SEA/TOAD,SF/TKW-FileMan: Continuation of DICLIX ;7/31/98 09:03
;;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.
;
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
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICLIX0 2147 printed Nov 22, 2024@17:56:10 Page 2
DICLIX0 ;SEA/TOAD,SF/TKW-FileMan: Continuation of DICLIX ;7/31/98 09:03
+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 ;
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 ;
