RGUTLKP.m

RGUTLKP ;CAIRO/DKM - File lookup utility;04-Sep-1998 11:26;DKM

 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999

 ;=================================================================

 ; Inputs:

 ;   %RGDIC  = Global root or file #

 ;   %RGOPT  = Options

 ;      A allow automatic selection of exact match

 ;      B sound bell with selection prompt

 ;      C use roll & scroll mode

 ;      D index is in date/time format

 ;      E use line editor

 ;      F forget the entry (i.e., ^DISV not updated)

 ;      G start with prior entry

 ;      H HTML-formatted output

 ;      I show only lookup identifiers

 ;      J show only secondary identifiers

 ;      K null entry at select prompt exits

 ;      L like X, but allows lookup at select prompt

 ;      M allow multiple selection

 ;      O show entry only once

 ;      P partial lookup

 ;      Q silent lookup

 ;      R reverse search through indices

 ;      S start selection list at last selection

 ;      T forget trapped inputs

 ;      U force uppercase translation

 ;      V extended DISV recall (prompt-specific)

 ;      W use multi-term lookup algorithm

 ;      X do not prompt for input

 ;      Y right justify secondary identifiers

 ;      Z perform special formatting of output

 ;      1 automatic selection if one match only

 ;      2-9 # of columns for selection display (default=1)

 ;      * force all indices to be searched

 ;      ^ allow search to be aborted

 ;   %RGPRMPT = Prompt (optional)

 ;   %RGXRFS  = Cross-references to examine (all "B"'s by default)

 ;   %RGDATA  = Data to lookup (optional)

 ;   %RGSCN   = Screening criteria (optional)

 ;   %RGMUL   = Local variable or global reference to

 ;              store multiple hits

 ;   %RGX     = Column position for prompt (optional)

 ;   %RGY     = Row position for prompt (optional)

 ;   %RGSID   = Piece # of secondary identifier (optional)

 ;              or executable M code to display same

 ;   %RGTRP   = Special inputs to trap (optional)

 ;   %RGHLP   = Entry point to invoke help

 ; Outputs:

 ;    Return value = index of selected entry or:

 ;      -1 for forced exit by ^

 ;      -2 for forced exit by ^^

 ;       0 for null entry

 ;=================================================================

ENTRY(%RGDIC,%RGOPT,%RGPRMPT,%RGXRFS,%RGDATA,%RGSCN,%RGMUL,%RGX,%RGY,%RGSID,%RGTRP,%RGHLP) ;

 N %,%1,%N,%S,%Z,%RGPID,%RGXRF,%RGSCT,%RGKEY,%RGKEY1,%RGDISV,%RGSLCT,%RGXRALL,%RGXRN,%RGSMAX,%RGTRUNC,%RGD,%RGD1,%RGD2,%RGBEL,%RGNUM,%RGDIR,%RGSLT,%RGCOL,%RGLAST,%RGSAME,%RGEOS,%RGEOL,%RGHTML,%RGRS,%RGQUIET

 I $$NEWERR^%ZTER N $ET S $ET=""

 S (%RGOPT,%RGOPT(0))=$$UP^XLFSTR($G(%RGOPT)),%RGPID="%RGLKP"_$J,%RGBEL=$S(%RGOPT["B":$C(7),1:""),%RGDIR=$S(%RGOPT["R":-1,1:1),%RGSLT=1,%RGCOL=1,%RGEOS=$C(27,91,74),%RGEOL=$C(27,91,75),%RGHTML=0,%RGLAST=0,%RGRS=%RGOPT["C",%RGQUIET=%RGOPT["Q"

 S:%RGRS (%RGEOL,%RGEOS)=""

 S:%RGQUIET %RGOPT=%RGOPT_"XHM"

 S:%RGOPT["H" (%RGBEL,%RGEOL,%RGEOS)="",%RGOPT=%RGOPT_"X",%RGHTML=1

 S:%RGOPT["L" %RGOPT=%RGOPT_"X"

 S U="^",DUZ=$G(DUZ,0),IO=$G(IO,$I),IOM=$G(IOM,80),%RGMUL=$G(%RGMUL),%RGHLP=$G(%RGHLP),%RGTRP=$G(%RGTRP),%RGSCN=$G(%RGSCN),%RGSAME=%RGOPT["M"&(%RGMUL'="")

 F %=2:1:9 S:%RGOPT[% %RGCOL=%

 S:%RGOPT'["M" %RGMUL=""

 K:%RGMUL'="" @%RGMUL

 S:%RGDIC=+%RGDIC %RGDIC=$$ROOT^DILFD(%RGDIC)

 S:$E(%RGDIC,$L(%RGDIC))="(" %RGDIC=$E(%RGDIC,1,$L(%RGDIC)-1)

 S:$E(%RGDIC,$L(%RGDIC))="," %RGDIC=$E(%RGDIC,1,$L(%RGDIC)-1)

 I %RGDIC["(",$E(%RGDIC,$L(%RGDIC))'=")" S %RGDIC=%RGDIC_")"

 S %RGPRMPT=$G(%RGPRMPT,$S(%RGOPT["X":"",1:"Enter identifier: "))

 S %RGDISV=$S(%RGDIC[")":$TR(%RGDIC,")",","),1:%RGDIC_"(")_$S(%RGOPT["V":";"_%RGPRMPT,1:"")

 S %RGSID=$G(%RGSID),%RGXRFS=$G(%RGXRFS),%RGDATA=$G(%RGDATA)

 S:%RGSID=+%RGSID %RGSID=$S(%RGSID<0:%RGSID,1:"$P(%Z,U,"_%RGSID_")")

 S %RGX=$G(%RGX,0),%RGY=$G(%RGY,3),DTIME=$G(DTIME,999999999)

 W:'%RGHTML $$XY(%RGX,%RGY),%RGEOS,!

 I %RGOPT["G",$G(^DISV(DUZ,%RGDISV))'="" D

 .S %RGDATA=^(%RGDISV)

 .S:+%RGDATA=%RGDATA %RGDATA=$P($G(@%RGDIC@(%RGDATA,0)),U)

 I %RGXRFS="" D

 .S (%,%RGXRFS)="B"

 .F  S %=$O(@%RGDIC@(%)) Q:$E(%)'="B"  S %RGXRFS=%RGXRFS_U_%

 F %=1:1:$L(%RGXRFS,U) S %1=$P(%RGXRFS,U,%) S:%1'="" %RGXRFS($P(%1,":"))=$P(%1,":",2),$P(%RGXRFS,U,%)=$P(%1,":")

 S (%RGD1,%RGD2)=""

 D RM(0)

 S %RGIEN=$$INPUT

 W:'%RGHTML $$XY(%RGX+$L(%RGPRMPT),%RGY),$$TRUNC^RGUT(%RGD2,IOM-$X),%RGEOS

 D RM(IOM)

 K ^TMP(%RGPID)

 Q %RGIEN

INPUT() ;

INP K ^TMP(%RGPID)

 D READ

 S:%RGOPT["U" %RGD=$$UP^XLFSTR(%RGD)

 S @$$TRAP^RGUTOS("ERROR^RGUTLKP")

 I %RGD="",%RGTRP'="" S %RGD=$G(@%RGTRP@(" "))

 Q:"^^"[%RGD -$L(%RGD)

 I "?"[%RGD D HELP1^RGUTLK2 G INP

 I %RGD=" " D SAME G:%RGD="" INP2

 I %RGTRP'="",$D(@%RGTRP@(%RGD)) D  Q %RGD

 .S %RGSAME=1

 .D:%RGOPT'["T" DISV^RGUTLK2(%RGD)

 .S %RGD2=$G(@%RGTRP@(%RGD))

 .S:%RGD2="" %RGD2=%RGD

 S:%RGD="??" %RGD=""

 I $E(%RGD,$L(%RGD))="*" S %RGXRALL=1,%RGD=$E(%RGD,1,$L(%RGD)-1)

 E  S %RGXRALL=%RGOPT["*"

 S %RGIEN=$$LKP^RGUTLK2(%RGD)

INP2 G INP:%RGIEN=""!$L(%RGD1)

 Q %RGIEN

READ S %RGD=""

 F  Q:%RGD'=""!(%RGD1="")  S %RGD=$P(%RGD1,";"),%RGD1=$P(%RGD1,";",2,999)

 Q:$L(%RGD)

 S %RGD=%RGDATA,%RGDATA=""

 W:'%RGHTML $$XY(0,%RGY+2),%RGEOS,$$XY(%RGX,%RGY),%RGPRMPT_%RGEOL

 I %RGOPT["X" S:%RGOPT["E" %RGOPT=$TR(%RGOPT,"X"),%RGDATA=%RGD Q

 I %RGOPT["E" D

 .N %,%1

 .S:%RGD?1"`"1.N %RGD=+$E(%RGD,2,99),%RGD=$$FMT^RGUTLK2(%RGD,$P($G(@%RGDIC@(%RGD,0)),U))

 .S %1=0,%=%RGX+$L(%RGPRMPT),%=$$ENTRY^RGUTEDT(%RGD,IOM-%-1,%,%RGY,"","RHV",,,,,.%1)

 .S:%1=3 %=U

 .S:%="?" %RGDATA=%RGD

 .S %RGD=%

 E  I '$L(%RGD) R %RGD:DTIME S:'$T %RGD=U

 I %RGOPT["M",%RGD[";" S %RGD1=%RGD G READ

 Q

SAME S %RGSAME=0,%RGIEN="",%RGD="",%RGSCT=0

 I %RGMUL'="" D

 .S %=""

 .F  S %=$O(^DISV(DUZ,%RGDISV,%)) Q:%=""  D SM1

 E  S %=$G(^DISV(DUZ,%RGDISV)) D:%'="" SM1

 S:%RGHTML %RGIEN=%RGSCT

 Q

SM1 I %RGTRP'="",$D(@%RGTRP@(%)) S %RGIEN=%,%RGD=%

 E  I $$VALD^RGUTLK2(%) S %RGIEN=%

 I  D DISV^RGUTLK2(%RGIEN) S %RGSCT=%RGSCT+1

 Q

XY(X,Y) Q $S(%RGRS:"",1:$$XY^RGUT(X,Y))

RM(X) X ^%ZOSF("RM")

 Q

ERROR W:'%RGHTML $$XY(0,%RGY+1),*7,%RGEOL,$$EC^%ZOSV

 S (%RGDATA,%RGD1,%RGD2)=""

 G INP

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RGUTLKP   6080     printed  Feb 19, 2025@00:03:53                                                                                                                                                                                                     Page 2

RGUTLKP   ;CAIRO/DKM - File lookup utility;04-Sep-1998 11:26;DKM

 +1       ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999

 +2       ;=================================================================

 +3       ; Inputs:

 +4       ;   %RGDIC  = Global root or file #

 +5       ;   %RGOPT  = Options

 +6       ;      A allow automatic selection of exact match

 +7       ;      B sound bell with selection prompt

 +8       ;      C use roll & scroll mode

 +9       ;      D index is in date/time format

 +10      ;      E use line editor

 +11      ;      F forget the entry (i.e., ^DISV not updated)

 +12      ;      G start with prior entry

 +13      ;      H HTML-formatted output

 +14      ;      I show only lookup identifiers

 +15      ;      J show only secondary identifiers

 +16      ;      K null entry at select prompt exits

 +17      ;      L like X, but allows lookup at select prompt

 +18      ;      M allow multiple selection

 +19      ;      O show entry only once

 +20      ;      P partial lookup

 +21      ;      Q silent lookup

 +22      ;      R reverse search through indices

 +23      ;      S start selection list at last selection

 +24      ;      T forget trapped inputs

 +25      ;      U force uppercase translation

 +26      ;      V extended DISV recall (prompt-specific)

 +27      ;      W use multi-term lookup algorithm

 +28      ;      X do not prompt for input

 +29      ;      Y right justify secondary identifiers

 +30      ;      Z perform special formatting of output

 +31      ;      1 automatic selection if one match only

 +32      ;      2-9 # of columns for selection display (default=1)

 +33      ;      * force all indices to be searched

 +34      ;      ^ allow search to be aborted

 +35      ;   %RGPRMPT = Prompt (optional)

 +36      ;   %RGXRFS  = Cross-references to examine (all "B"'s by default)

 +37      ;   %RGDATA  = Data to lookup (optional)

 +38      ;   %RGSCN   = Screening criteria (optional)

 +39      ;   %RGMUL   = Local variable or global reference to

 +40      ;              store multiple hits

 +41      ;   %RGX     = Column position for prompt (optional)

 +42      ;   %RGY     = Row position for prompt (optional)

 +43      ;   %RGSID   = Piece # of secondary identifier (optional)

 +44      ;              or executable M code to display same

 +45      ;   %RGTRP   = Special inputs to trap (optional)

 +46      ;   %RGHLP   = Entry point to invoke help

 +47      ; Outputs:

 +48      ;    Return value = index of selected entry or:

 +49      ;      -1 for forced exit by ^

 +50      ;      -2 for forced exit by ^^

 +51      ;       0 for null entry

 +52      ;=================================================================

ENTRY(%RGDIC,%RGOPT,%RGPRMPT,%RGXRFS,%RGDATA,%RGSCN,%RGMUL,%RGX,%RGY,%RGSID,%RGTRP,%RGHLP) ;

 +1        NEW %,%1,%N,%S,%Z,%RGPID,%RGXRF,%RGSCT,%RGKEY,%RGKEY1,%RGDISV,%RGSLCT,%RGXRALL,%RGXRN,%RGSMAX,%RGTRUNC,%RGD,%RGD1,%RGD2,%RGBEL,%RGNUM,%RGDIR,%RGSLT,%RGCOL,%RGLAST,%RGSAME,%RGEOS,%RGEOL,%RGHTML,%RGRS,%RGQUIET

 +2        IF $$NEWERR^%ZTER

               NEW $ETRAP

               SET $ETRAP=""

 +3        SET (%RGOPT,%RGOPT(0))=$$UP^XLFSTR($GET(%RGOPT))

           SET %RGPID="%RGLKP"_$JOB

           SET %RGBEL=$SELECT(%RGOPT["B":$CHAR(7),1:"")

           SET %RGDIR=$SELECT(%RGOPT["R":-1,1:1)

           SET %RGSLT=1

           SET %RGCOL=1

           SET %RGEOS=$CHAR(27,91,74)

           SET %RGEOL=$CHAR(27,91,75)

           SET %RGHTML=0

           SET %RGLAST=0

           SET %RGRS=%RGOPT["C"

           SET %RGQUIET=%RGOPT["Q"

 +4        if %RGRS

               SET (%RGEOL,%RGEOS)=""

 +5        if %RGQUIET

               SET %RGOPT=%RGOPT_"XHM"

 +6        if %RGOPT["H"

               SET (%RGBEL,%RGEOL,%RGEOS)=""

               SET %RGOPT=%RGOPT_"X"

               SET %RGHTML=1

 +7        if %RGOPT["L"

               SET %RGOPT=%RGOPT_"X"

 +8        SET U="^"

           SET DUZ=$GET(DUZ,0)

           SET IO=$GET(IO,$IO)

           SET IOM=$GET(IOM,80)

           SET %RGMUL=$GET(%RGMUL)

           SET %RGHLP=$GET(%RGHLP)

           SET %RGTRP=$GET(%RGTRP)

           SET %RGSCN=$GET(%RGSCN)

           SET %RGSAME=%RGOPT["M"&(%RGMUL'="")

 +9        FOR %=2:1:9

               if %RGOPT[%

                   SET %RGCOL=%

 +10       if %RGOPT'["M"

               SET %RGMUL=""

 +11       if %RGMUL'=""

               KILL @%RGMUL

 +12       if %RGDIC=+%RGDIC

               SET %RGDIC=$$ROOT^DILFD(%RGDIC)

 +13       if $EXTRACT(%RGDIC,$LENGTH(%RGDIC))="("

               SET %RGDIC=$EXTRACT(%RGDIC,1,$LENGTH(%RGDIC)-1)

 +14       if $EXTRACT(%RGDIC,$LENGTH(%RGDIC))=","

               SET %RGDIC=$EXTRACT(%RGDIC,1,$LENGTH(%RGDIC)-1)

 +15       IF %RGDIC["("

               IF $EXTRACT(%RGDIC,$LENGTH(%RGDIC))'=")"

                   SET %RGDIC=%RGDIC_")"

 +16       SET %RGPRMPT=$GET(%RGPRMPT,$SELECT(%RGOPT["X":"",1:"Enter identifier: "))

 +17       SET %RGDISV=$SELECT(%RGDIC[")":$TRANSLATE(%RGDIC,")",","),1:%RGDIC_"(")_$SELECT(%RGOPT["V":";"_%RGPRMPT,1:"")

 +18       SET %RGSID=$GET(%RGSID)

           SET %RGXRFS=$GET(%RGXRFS)

           SET %RGDATA=$GET(%RGDATA)

 +19       if %RGSID=+%RGSID

               SET %RGSID=$SELECT(%RGSID<0:%RGSID,1:"$P(%Z,U,"_%RGSID_")")

 +20       SET %RGX=$GET(%RGX,0)

           SET %RGY=$GET(%RGY,3)

           SET DTIME=$GET(DTIME,999999999)

 +21       if '%RGHTML

               WRITE $$XY(%RGX,%RGY),%RGEOS,!

 +22       IF %RGOPT["G"

               IF $GET(^DISV(DUZ,%RGDISV))'=""

                   Begin DoDot:1

 +23                   SET %RGDATA=^(%RGDISV)

 +24                   if +%RGDATA=%RGDATA

                           SET %RGDATA=$PIECE($GET(@%RGDIC@(%RGDATA,0)),U)

                   End DoDot:1

 +25       IF %RGXRFS=""

               Begin DoDot:1

 +26               SET (%,%RGXRFS)="B"

 +27               FOR 

                       SET %=$ORDER(@%RGDIC@(%))

                       if $EXTRACT(%)'="B"

                           QUIT 

                       SET %RGXRFS=%RGXRFS_U_%

               End DoDot:1

 +28       FOR %=1:1:$LENGTH(%RGXRFS,U)

               SET %1=$PIECE(%RGXRFS,U,%)

               if %1'=""

                   SET %RGXRFS($PIECE(%1,":"))=$PIECE(%1,":",2)

                   SET $PIECE(%RGXRFS,U,%)=$PIECE(%1,":")

 +29       SET (%RGD1,%RGD2)=""

 +30       DO RM(0)

 +31       SET %RGIEN=$$INPUT

 +32       if '%RGHTML

               WRITE $$XY(%RGX+$LENGTH(%RGPRMPT),%RGY),$$TRUNC^RGUT(%RGD2,IOM-$X),%RGEOS

 +33       DO RM(IOM)

 +34       KILL ^TMP(%RGPID)

 +35       QUIT %RGIEN

INPUT()   ;

INP        KILL ^TMP(%RGPID)

 +1        DO READ

 +2        if %RGOPT["U"

               SET %RGD=$$UP^XLFSTR(%RGD)

 +3        SET @$$TRAP^RGUTOS("ERROR^RGUTLKP")

 +4        IF %RGD=""

               IF %RGTRP'=""

                   SET %RGD=$GET(@%RGTRP@(" "))

 +5        if "^^"[%RGD

               QUIT -$LENGTH(%RGD)

 +6        IF "?"[%RGD

               DO HELP1^RGUTLK2

               GOTO INP

 +7        IF %RGD=" "

               DO SAME

               if %RGD=""

                   GOTO INP2

 +8        IF %RGTRP'=""

               IF $DATA(@%RGTRP@(%RGD))

                   Begin DoDot:1

 +9                    SET %RGSAME=1

 +10                   if %RGOPT'["T"

                           DO DISV^RGUTLK2(%RGD)

 +11                   SET %RGD2=$GET(@%RGTRP@(%RGD))

 +12                   if %RGD2=""

                           SET %RGD2=%RGD

                   End DoDot:1

                   QUIT %RGD

 +13       if %RGD="??"

               SET %RGD=""

 +14       IF $EXTRACT(%RGD,$LENGTH(%RGD))="*"

               SET %RGXRALL=1

               SET %RGD=$EXTRACT(%RGD,1,$LENGTH(%RGD)-1)

 +15      IF '$TEST

               SET %RGXRALL=%RGOPT["*"

 +16       SET %RGIEN=$$LKP^RGUTLK2(%RGD)

INP2       if %RGIEN=""!$LENGTH(%RGD1)

               GOTO INP

 +1        QUIT %RGIEN

READ       SET %RGD=""

 +1        FOR 

               if %RGD'=""!(%RGD1="")

                   QUIT 

               SET %RGD=$PIECE(%RGD1,";")

               SET %RGD1=$PIECE(%RGD1,";",2,999)

 +2        if $LENGTH(%RGD)

               QUIT 

 +3        SET %RGD=%RGDATA

           SET %RGDATA=""

 +4        if '%RGHTML

               WRITE $$XY(0,%RGY+2),%RGEOS,$$XY(%RGX,%RGY),%RGPRMPT_%RGEOL

 +5        IF %RGOPT["X"

               if %RGOPT["E"

                   SET %RGOPT=$TRANSLATE(%RGOPT,"X")

                   SET %RGDATA=%RGD

               QUIT 

 +6        IF %RGOPT["E"

               Begin DoDot:1

 +7                NEW %,%1

 +8                if %RGD?1"`"1.N

                       SET %RGD=+$EXTRACT(%RGD,2,99)

                       SET %RGD=$$FMT^RGUTLK2(%RGD,$PIECE($GET(@%RGDIC@(%RGD,0)),U))

 +9                SET %1=0

                   SET %=%RGX+$LENGTH(%RGPRMPT)

                   SET %=$$ENTRY^RGUTEDT(%RGD,IOM-%-1,%,%RGY,"","RHV",,,,,.%1)

 +10               if %1=3

                       SET %=U

 +11               if %="?"

                       SET %RGDATA=%RGD

 +12               SET %RGD=%

               End DoDot:1

 +13      IF '$TEST

               IF '$LENGTH(%RGD)

                   READ %RGD:DTIME

                   if '$TEST

                       SET %RGD=U

 +14       IF %RGOPT["M"

               IF %RGD[";"

                   SET %RGD1=%RGD

                   GOTO READ

 +15       QUIT 

SAME       SET %RGSAME=0

           SET %RGIEN=""

           SET %RGD=""

           SET %RGSCT=0

 +1        IF %RGMUL'=""

               Begin DoDot:1

 +2                SET %=""

 +3                FOR 

                       SET %=$ORDER(^DISV(DUZ,%RGDISV,%))

                       if %=""

                           QUIT 

                       DO SM1

               End DoDot:1

 +4       IF '$TEST

               SET %=$GET(^DISV(DUZ,%RGDISV))

               if %'=""

                   DO SM1

 +5        if %RGHTML

               SET %RGIEN=%RGSCT

 +6        QUIT 

SM1        IF %RGTRP'=""

               IF $DATA(@%RGTRP@(%))

                   SET %RGIEN=%

                   SET %RGD=%

 +1       IF '$TEST

               IF $$VALD^RGUTLK2(%)

                   SET %RGIEN=%

 +2       IF $TEST

               DO DISV^RGUTLK2(%RGIEN)

               SET %RGSCT=%RGSCT+1

 +3        QUIT 

XY(X,Y)    QUIT $SELECT(%RGRS:"",1:$$XY^RGUT(X,Y))

RM(X)      XECUTE ^%ZOSF("RM")

 +1        QUIT 

ERROR      if '%RGHTML

               WRITE $$XY(0,%RGY+1),*7,%RGEOL,$$EC^%ZOSV

 +1        SET (%RGDATA,%RGD1,%RGD2)=""

 +2        GOTO INP