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 ---[H[J[2J[HRGUTLKP 6080 printed Apr 09, 2024@21:39:56 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
