DICFIX1.m

DICFIX1 ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes (cont.) ;15MAY2011

 ;;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.

 ;

 ;

NXTNAM(DIVAL,DIPART,DINDEX,DISKIP,DIDONE) ;

 ; limited comma piece lookup, skip nonmatching names in index

 N DIUTF8 D

 .N X,Y S Y=$C(126),X=$G(^DD("OS",^DD("OS"),"HIGHESTCHAR")) X:X]"" X S DIUTF8=Y

 I $P(DIVAL,",")=DIPART S DIVAL=DIPART_","_DIUTF8,DISKIP=1 Q  ;UTH/SMH

 N DIPREC,DIPOSTC,DIPPOSTC

 S DIPREC=$P(DIVAL,","),DIPOSTC=$P(DIVAL,",",2)

 S DIPPOSTC=DINDEX(DISUB,DITRXNO,"c")

 I $$PREFIX(DIPOSTC,DIPPOSTC) Q

 I $$PREFIX(DIPPOSTC,DIPOSTC) Q

 D SKIP(.DISKIP,.DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,.DINDEX)

 Q

 ;

PREFIX(DISTRING,DIPREFIX) ;

 Q $E(DISTRING,1,$L(DIPREFIX))=DIPREFIX

 ;

SKIP(DISKIP,DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,DINDEX) ;

 ; Skip forward within index based on limited comma piecing

 I DIPPOSTC]DIPOSTC D  Q

 . ; Current first name before starting first name, skip to starting first name

 . S DIVAL=DIPREC_","_DIPPOSTC

 . I '$D(@DINDEX(DISUB,"ROOT")@(DIVAL)) S DISKIP=1

 ; Else, skip the rest of the first names within current last name.

 S DIVAL=DIPREC_","_DIUTF8,DISKIP=1 Q  ;UTH/SMH

 ;

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DICFIX1   1441     printed  Apr 09, 2024@21:46:23                                                                                                                                                                                                     Page 2

DICFIX1   ;SEA/TOAD,SF/TKW-FileMan: Finder, Search Compound Indexes (cont.) ;15MAY2011

 +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       ;

NXTNAM(DIVAL,DIPART,DINDEX,DISKIP,DIDONE) ;

 +1       ; limited comma piece lookup, skip nonmatching names in index

 +2        NEW DIUTF8

           Begin DoDot:1

 +3            NEW X,Y

               SET Y=$CHAR(126)

               SET X=$GET(^DD("OS",^DD("OS"),"HIGHESTCHAR"))

               if X]""

                   XECUTE X

               SET DIUTF8=Y

           End DoDot:1

 +4       ;UTH/SMH

           IF $PIECE(DIVAL,",")=DIPART

               SET DIVAL=DIPART_","_DIUTF8

               SET DISKIP=1

               QUIT 

 +5        NEW DIPREC,DIPOSTC,DIPPOSTC

 +6        SET DIPREC=$PIECE(DIVAL,",")

           SET DIPOSTC=$PIECE(DIVAL,",",2)

 +7        SET DIPPOSTC=DINDEX(DISUB,DITRXNO,"c")

 +8        IF $$PREFIX(DIPOSTC,DIPPOSTC)

               QUIT 

 +9        IF $$PREFIX(DIPPOSTC,DIPOSTC)

               QUIT 

 +10       DO SKIP(.DISKIP,.DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,.DINDEX)

 +11       QUIT 

 +12      ;

PREFIX(DISTRING,DIPREFIX) ;

 +1        QUIT $EXTRACT(DISTRING,1,$LENGTH(DIPREFIX))=DIPREFIX

 +2       ;

SKIP(DISKIP,DIVAL,DIPREC,DIPOSTC,DIPART,DIPPOSTC,DINDEX) ;

 +1       ; Skip forward within index based on limited comma piecing

 +2        IF DIPPOSTC]DIPOSTC

               Begin DoDot:1

 +3       ; Current first name before starting first name, skip to starting first name

 +4                SET DIVAL=DIPREC_","_DIPPOSTC

 +5                IF '$DATA(@DINDEX(DISUB,"ROOT")@(DIVAL))

                       SET DISKIP=1

               End DoDot:1

               QUIT 

 +6       ; Else, skip the rest of the first names within current last name.

 +7       ;UTH/SMH

           SET DIVAL=DIPREC_","_DIUTF8

           SET DISKIP=1

           QUIT 

 +8       ;

 +9       ;