RGUTLK2 ;CAIRO/DKM - Continuation of RGUTLKP;04-Sep-1998 11:26;DKM
;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
LKP(%RGDX) ;
N %RGD,%RGZ,%RGN
S %RGXRN=0,%RGTRUNC=0,%RGIEN="",%RGSCT=0,%RGD=%RGDX
W:'%RGHTML $$XY(%RGX+$L(%RGPRMPT),%RGY),$S(%RGOPT["X":"",1:%RGD),%RGEOS,!,"Searching"_$S(%RGOPT[U:" (press ^ to abort)",1:"")_"...",*13
I $E(%RGD)="`" S %RGSLCT=%RGD G:'%RGHTML NR5 D SHOW($E(%RGD,2,999)) Q 1
NXTREF S %RGXRN=%RGXRN+1,%RGXRF=$P(%RGXRFS,U,%RGXRN),%RGD=%RGDX
I %RGXRF="" G:%RGSCT NR3 W:'%RGHTML *7,*13,%RGEOL,"Not found"_$S(%RGD="":".",1:": ")_$S(%RGD'=+%RGD:%RGD,%RGOPT["D":$$ENTRY^RGUTDT(%RGD),1:%RGD) S %RGD1=$S(%RGOPT["X":U,1:"") Q ""
S %RGOPT(0)=%RGOPT_%RGXRFS(%RGXRF)
I %RGOPT(0)["D",$L(%RGDX) D G:%RGD<1 NXTREF
.S %RGD=$$%DT^RGUT(%RGDX)
I %RGOPT(0)["W" D MTL G NXTREF
S %RGKEY=$S(%RGOPT(0)["P":$P(%RGD," "),1:%RGD)_$S(%RGDIR<0:$C(255),1:""),%RGNUM=$S(%RGKEY=+%RGKEY:%RGKEY,1:"")
I %RGD'="",$D(@%RGDIC@(%RGXRF,%RGD)) S %=%RGSCT+1 D ADD(%RGD) I %RGSCT=%,%RGOPT(0)["A" D SLCT(%RGSCT) Q %RGIEN
NR2 I %RGOPT(0)[U R %#1:0 I %=U S %RGTRUNC=1 G NR3:%RGSCT Q ""
S %RGKEY=$O(@%RGDIC@(%RGXRF,%RGKEY),%RGDIR)
I (%RGNUM="")=(%RGKEY=+%RGKEY),%RGD'="" S %RGKEY=""
I %RGKEY'="",%RGOPT(0)["P",%RGKEY'=%RGD S %=$$PARTIAL(%RGD,%RGKEY) D ADD(%RGKEY):%>0 G:%'<0 NR2:%RGSCT<100
I %RGKEY'="",%RGOPT(0)'["P",$E(%RGKEY,1,$L(%RGD))=%RGD D ADD(%RGKEY) G:%RGSCT<100 NR2
I %RGNUM'="" S %RGKEY=%RGNUM_$C($S(%RGDIR<0:255,1:1)),%RGNUM="" G NR2
I %RGSCT'<100 W:'%RGHTML *7 S %RGXRALL=0,%RGTRUNC=1
G:'%RGSCT!%RGXRALL NXTREF
NR3 I %RGSCT=1,%RGOPT(0)[1,'%RGTRUNC D SLCT(1) Q %RGIEN
S %RGKEY=%RGSLT,%RGSLT=1,%RGSMAX=$S(%RGHTML:99999,1:17-%RGY)
NR4 W:'%RGHTML $$XY(0,%RGY+1),%RGEOS,!
F %RGN=%RGKEY:1:%RGKEY+%RGSMAX-1 D Q:%RGN=%RGSCT
.F %RGZ=0:1:%RGCOL-1 D
..S %1=IOM/%RGCOL*%RGZ\1,%RGLAST=%RGZ*%RGSMAX+%RGN
..Q:%RGLAST>%RGSCT
..W:'%RGHTML $$XY(%1,$Y),%RGEOL,%RGLAST,?5
..D SHOW(^TMP(%RGPID,%RGLAST),%1+4)
.W:'%RGQUIET !
Q:%RGHTML $S(%RGTRUNC:-%RGSCT,1:%RGSCT)
W:%RGLAST<%RGSCT !,%RGSCT-%RGLAST," more choice(s)..."
W:%RGTRUNC " (list was truncated)",!
W %RGEOS_%RGBEL,!!
R "Enter selection: ",%RGSLCT:DTIME
S:'$T %RGSLCT=U
W *13
I %RGOPT["K",%RGSLCT="" Q -1
I "Nn"[%RGSLCT S %RGKEY=$S(%RGLAST<%RGSCT:%RGLAST+1,1:1) G NR4
I "Bb"[%RGSLCT S %RGKEY=$S(%RGKEY=1:%RGSCT-%RGSMAX+1,%RGKEY'>%RGSMAX:1,1:%RGKEY-%RGSMAX) S:%RGKEY<1 %RGKEY=1 G NR4
I "?"[%RGSLCT D HELP2 G NR4
I "^^"[%RGSLCT S %RGD2="",%RGD1=$S(%RGOPT(0)["X":%RGSLCT,%RGSLCT="^^":%RGSLCT,1:"") Q ""
NR5 F D Q:%RGSLCT=""
.I %RGOPT(0)["M" S %RGD=$P(%RGSLCT,";"),%RGSLCT=$P(%RGSLCT,";",2,999)
.E S %RGD=%RGSLCT,%RGSLCT=""
.Q:'$L(%RGD)
.I %RGD?1.N D SLCT(%RGD) Q
.I %RGOPT(0)["M",%RGD?1.N1"-".N D Q
..N %1,%2
..S %1=+%RGD,%2=+$P(%RGD,"-",2)
..S:'%2 %2=%RGSCT
..S:%1>%2 %RGD=%1,%1=%2,%2=%RGD
..S:%2>%RGSCT %2=%RGSCT
..F %=%1:1:%2 D SLCT(%)
.I %RGOPT["X",%RGOPT'["L" S (%RGSLCT,%RGD1,%RGIEN)="" Q
.I $E(%RGD)="`" D Q
..S %RGD=+$E(%RGD,2,999)
..I $$VALD(%RGD) D DISV(%RGD) S %RGIEN=%RGD
.S %RGD1=%RGD1_";"_%RGD
W $$XY(0,%RGY+1),%RGEOS,!
Q %RGIEN
; Add list selection to output
SLCT(%RGSLCT) ;
I %RGSLCT>0,%RGSLCT'>%RGSCT D
.S %RGIEN=+^TMP(%RGPID,+%RGSLCT)
.D DISV(%RGIEN)
Q
; Add IEN to output
DISV(%RGIEN) ;
Q:%RGIEN=""
I %RGMUL'="",'$D(@%RGMUL@(%RGIEN)) S @%RGMUL@(%RGIEN)="" D:'%RGQUIET APP(%RGIEN)
D:%RGMUL="" APP(%RGIEN)
Q:%RGOPT(0)["F"
K:%RGSAME ^DISV(DUZ,%RGDISV)
S %RGSAME=0,^DISV(DUZ,%RGDISV)=%RGIEN,^(%RGDISV,%RGIEN)=""
Q
; Append primary key to key list
APP(%RGIEN) ;
N %RGKEY
S %RGKEY=$S(%RGIEN=+%RGIEN:$P($G(@%RGDIC@(%RGIEN,0)),U),1:%RGIEN)
S %RGKEY=$$FMT(%RGIEN,%RGKEY)
Q:'$L(%RGKEY)!($L(%RGKEY)+$L(%RGD2)'<250)
S %RGD2=%RGD2_$S($L(%RGD2):";",1:"")_%RGKEY
I %RGOPT(0)'["J",%RGOPT(0)'["M" S %RGD2=%RGD2_" "_$$SID(%RGIEN)
Q
; Multi-term lookup
MTL N %
S %=$S(%RGDIC[")":$TR(%RGDIC,")",","),1:%RGDIC_"(")_"%RGXRF)"
S %=$$LKP^RGUTMTL(%,%RGD,"^TMP(""MTL"",%RGPID)",%RGOPT(0)[U)
S:%<0 %RGTRUNC=1
D:% ADD(%RGPID,"^TMP","MTL")
K ^TMP("MTL",%RGPID)
Q
; Add key to selection list
ADD(%RGKEY,%RGIDX,%RGSUB) ;
N %S
S:'$D(%RGIDX) %RGIDX=%RGDIC,%RGSUB=%RGXRF
F %S=0:0 S %S=$O(@%RGIDX@(%RGSUB,%RGKEY,%S)) Q:'%S D
.I %RGOPT(0)["O",$D(^TMP(%RGPID,0,%S)) Q
.I $$VALD(%S) D
..S %RGSCT=%RGSCT+1,^TMP(%RGPID,%RGSCT)=%S_U_$S(%RGOPT(0)["W":"",1:%RGKEY),^(0,%S)=""
..I %RGOPT(0)["S",$G(^DISV(DUZ,%RGDISV))=%S S %RGSLT=%RGSCT
Q
; Check entry against screening criteria
VALD(%S) Q:'$D(@%RGDIC@(%S))!'%S 0
Q:%RGSCN="" 1
N %,%1
S %1=1,@$$TRAP^RGUTOS("V3^RGUTLK2")
F %=0:0 S %=$O(@%RGSCN@(%)) Q:'% D Q:%1
.S %1=0,@$$TRAP^RGUTOS("V2^RGUTLK2")
.X "S %1="_@%RGSCN@(%)
V2 .Q
Q %1
V3 Q 0
; Show the specified selection
SHOW(%RGSLCT,%RGCOL1,%RGCOL2) ;
N %S,%Z,%P,%I
S %S=+%RGSLCT,%Z=$G(@%RGDIC@(%S,0)),%P=$$FMT(%S,$S(%RGOPT["I":$P(%RGSLCT,U,2),1:$P(%Z,U)))
;S %I=$$SID(%S,$P(%RGSLCT,U,2)),%I=$S(%I="":%P,1:%I)
S %I=$$SID(%S,%P),%I=$S(%I="":%P,1:%I)
I %RGHTML D Q
.I '%RGQUIET W $$MSG^RGUT(%RGPRMPT,"|"),!
.E D DISV(%S)
S %RGCOL1=+$G(%RGCOL1,$X)
I %RGOPT(0)["Y" S %RGCOL2=+$G(%RGCOL2,IOM\%RGCOL+%RGCOL1-8-$L(%I))
E S %RGCOL2=+$G(%RGCOL2,IOM\%RGCOL\$S(%RGOPT(0)["D":3,1:2)-3+%RGCOL1)
W $$XY(%RGCOL1,$Y)
I %RGOPT(0)'["J",%I'=%P W $$TRUNC^RGUT(%P,IOM\%RGCOL-6),?%RGCOL2," "_$$TRUNC^RGUT(%I,IOM-%RGCOL2-2)
E W $$TRUNC^RGUT(%I,IOM\%RGCOL-6)
Q
; Return external form of result
FMT(%S,%RGKEY) ;
Q:%RGKEY="" %RGKEY
I %RGTRP'="",$D(@%RGTRP@(%RGKEY)) Q @%RGTRP@(%RGKEY)
S:%RGOPT(0)["D" %RGKEY=$$ENTRY^RGUTDT(%RGKEY)
I %RGOPT(0)["Z",%RGSCN'="",$G(@%RGSCN)'="" S @("%RGKEY="_@%RGSCN)
S:%RGOPT["J" %RGKEY=$$SID(%S,%RGKEY)
Q %RGKEY
; Return secondary identifier
SID(%S,%RGKEY) ;
S %RGKEY=$G(%RGKEY)
N %Z
S %Z=$G(@%RGDIC@(%S,0)),@("%Z="_$S(%RGSID<0:$S(%RGKEY=$$UP^XLFSTR($P(%Z,U)):"""""",1:"%RGKEY"),%RGSID="":"%RGSID",1:%RGSID))
Q %Z
; Partial key lookup
PARTIAL(%RGD,%RGKEY) ;
N %,%1,%2
S (%(1),%(2))=0,%1(1)=%RGD,%1(2)=%RGKEY
F %=1,2 S %1(%)=$TR(%1(%),".,;:?/!-"," ")
P1 S (%2(1),%2(2))=""
F %=1,2 D
.F %(%)=%(%)+1:1:$L(%1(%)," ") S %2(%)=$P(%1(%)," ",%(%)) Q:%2(%)'=""
Q:%2(1)="" 1
Q:%2(1)'=$E(%2(2),1,$L(%2(1))) -(%(1)=1)
G P1
HELP(X) ; Application-specific help
N %
S %=""
F S %=$O(X(%)) Q:%="" D:$Y>20 PAUSE W $G(X(%)),!
Q
; Generic help
HELP1 N %
W !!
D:%RGHLP'="" @%RGHLP
W !,"Enter a blank line for default action.",!
D:$Y>20 PAUSE
W:%RGOPT'["W" "Enter ?? to see all possible selections.",!
D:$Y>20 PAUSE
W "Enter a space to retrieve previous selection.",!
D:$Y>20 PAUSE
W "Enter a valid identifier for lookup."
W:(%RGOPT'["*")&(%RGXRFS[U) " Append a * to include all indices."
W !
I %RGOPT["M" D
.D:$Y>20 PAUSE
.W "Separate multiple selections by semicolons."
R !!,"Press any key to continue...",*%:DTIME
Q
; Help at choice prompt
HELP2 N %
W $$XY(0,16),%RGEOS,!
W $S(%RGOPT(0)["K":"Enter N for next choices.",1:"Press RETURN for more choices.")
W ?35,"Enter B for previous choices.",!
W "Enter ^ to abort lookup.",?35,"Enter choice number to select.",!
W "Any other entry = new lookup."
W:%RGOPT(0)["M" ?35,"Separate multiple selections by semicolons."
R !!,"Press any key to continue...",*%:DTIME
Q
PAUSE N %
R !,"Press any key for more...",*%:DTIME
W $$XY(0,%RGY+2),%RGEOS
Q
XY(X,Y) Q $S(%RGRS:"",1:$$XY^RGUT(X,Y))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGUTLK2 7400 printed Apr 09, 2024@21:39:45 Page 2
RGUTLK2 ;CAIRO/DKM - Continuation of RGUTLKP;04-Sep-1998 11:26;DKM
+1 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
LKP(%RGDX) ;
+1 NEW %RGD,%RGZ,%RGN
+2 SET %RGXRN=0
SET %RGTRUNC=0
SET %RGIEN=""
SET %RGSCT=0
SET %RGD=%RGDX
+3 if '%RGHTML
WRITE $$XY(%RGX+$LENGTH(%RGPRMPT),%RGY),$SELECT(%RGOPT["X":"",1:%RGD),%RGEOS,!,"Searching"_$SELECT(%RGOPT[U:" (press ^ to abort)",1:"")_"...",*13
+4 IF $EXTRACT(%RGD)="`"
SET %RGSLCT=%RGD
if '%RGHTML
GOTO NR5
DO SHOW($EXTRACT(%RGD,2,999))
QUIT 1
NXTREF SET %RGXRN=%RGXRN+1
SET %RGXRF=$PIECE(%RGXRFS,U,%RGXRN)
SET %RGD=%RGDX
+1 IF %RGXRF=""
if %RGSCT
GOTO NR3
if '%RGHTML
WRITE *7,*13,%RGEOL,"Not found"_$SELECT(%RGD="":".",1:": ")_$SELECT(%RGD'=+%RGD:%RGD,%RGOPT["D":$$ENTRY^RGUTDT(%RGD),1:%RGD)
SET %RGD1=$SELECT(%RGOPT["X":U,1:"")
QUIT ""
+2 SET %RGOPT(0)=%RGOPT_%RGXRFS(%RGXRF)
+3 IF %RGOPT(0)["D"
IF $LENGTH(%RGDX)
Begin DoDot:1
+4 SET %RGD=$$%DT^RGUT(%RGDX)
End DoDot:1
if %RGD<1
GOTO NXTREF
+5 IF %RGOPT(0)["W"
DO MTL
GOTO NXTREF
+6 SET %RGKEY=$SELECT(%RGOPT(0)["P":$PIECE(%RGD," "),1:%RGD)_$SELECT(%RGDIR<0:$CHAR(255),1:"")
SET %RGNUM=$SELECT(%RGKEY=+%RGKEY:%RGKEY,1:"")
+7 IF %RGD'=""
IF $DATA(@%RGDIC@(%RGXRF,%RGD))
SET %=%RGSCT+1
DO ADD(%RGD)
IF %RGSCT=%
IF %RGOPT(0)["A"
DO SLCT(%RGSCT)
QUIT %RGIEN
NR2 IF %RGOPT(0)[U
READ %#1:0
IF %=U
SET %RGTRUNC=1
if %RGSCT
GOTO NR3
QUIT ""
+1 SET %RGKEY=$ORDER(@%RGDIC@(%RGXRF,%RGKEY),%RGDIR)
+2 IF (%RGNUM="")=(%RGKEY=+%RGKEY)
IF %RGD'=""
SET %RGKEY=""
+3 IF %RGKEY'=""
IF %RGOPT(0)["P"
IF %RGKEY'=%RGD
SET %=$$PARTIAL(%RGD,%RGKEY)
if %>0
DO ADD(%RGKEY)
if %'<0
if %RGSCT<100
GOTO NR2
+4 IF %RGKEY'=""
IF %RGOPT(0)'["P"
IF $EXTRACT(%RGKEY,1,$LENGTH(%RGD))=%RGD
DO ADD(%RGKEY)
if %RGSCT<100
GOTO NR2
+5 IF %RGNUM'=""
SET %RGKEY=%RGNUM_$CHAR($SELECT(%RGDIR<0:255,1:1))
SET %RGNUM=""
GOTO NR2
+6 IF %RGSCT'<100
if '%RGHTML
WRITE *7
SET %RGXRALL=0
SET %RGTRUNC=1
+7 if '%RGSCT!%RGXRALL
GOTO NXTREF
NR3 IF %RGSCT=1
IF %RGOPT(0)[1
IF '%RGTRUNC
DO SLCT(1)
QUIT %RGIEN
+1 SET %RGKEY=%RGSLT
SET %RGSLT=1
SET %RGSMAX=$SELECT(%RGHTML:99999,1:17-%RGY)
NR4 if '%RGHTML
WRITE $$XY(0,%RGY+1),%RGEOS,!
+1 FOR %RGN=%RGKEY:1:%RGKEY+%RGSMAX-1
Begin DoDot:1
+2 FOR %RGZ=0:1:%RGCOL-1
Begin DoDot:2
+3 SET %1=IOM/%RGCOL*%RGZ\1
SET %RGLAST=%RGZ*%RGSMAX+%RGN
+4 if %RGLAST>%RGSCT
QUIT
+5 if '%RGHTML
WRITE $$XY(%1,$Y),%RGEOL,%RGLAST,?5
+6 DO SHOW(^TMP(%RGPID,%RGLAST),%1+4)
End DoDot:2
+7 if '%RGQUIET
WRITE !
End DoDot:1
if %RGN=%RGSCT
QUIT
+8 if %RGHTML
QUIT $SELECT(%RGTRUNC:-%RGSCT,1:%RGSCT)
+9 if %RGLAST<%RGSCT
WRITE !,%RGSCT-%RGLAST," more choice(s)..."
+10 if %RGTRUNC
WRITE " (list was truncated)",!
+11 WRITE %RGEOS_%RGBEL,!!
+12 READ "Enter selection: ",%RGSLCT:DTIME
+13 if '$TEST
SET %RGSLCT=U
+14 WRITE *13
+15 IF %RGOPT["K"
IF %RGSLCT=""
QUIT -1
+16 IF "Nn"[%RGSLCT
SET %RGKEY=$SELECT(%RGLAST<%RGSCT:%RGLAST+1,1:1)
GOTO NR4
+17 IF "Bb"[%RGSLCT
SET %RGKEY=$SELECT(%RGKEY=1:%RGSCT-%RGSMAX+1,%RGKEY'>%RGSMAX:1,1:%RGKEY-%RGSMAX)
if %RGKEY<1
SET %RGKEY=1
GOTO NR4
+18 IF "?"[%RGSLCT
DO HELP2
GOTO NR4
+19 IF "^^"[%RGSLCT
SET %RGD2=""
SET %RGD1=$SELECT(%RGOPT(0)["X":%RGSLCT,%RGSLCT="^^":%RGSLCT,1:"")
QUIT ""
NR5 FOR
Begin DoDot:1
+1 IF %RGOPT(0)["M"
SET %RGD=$PIECE(%RGSLCT,";")
SET %RGSLCT=$PIECE(%RGSLCT,";",2,999)
+2 IF '$TEST
SET %RGD=%RGSLCT
SET %RGSLCT=""
+3 if '$LENGTH(%RGD)
QUIT
+4 IF %RGD?1.N
DO SLCT(%RGD)
QUIT
+5 IF %RGOPT(0)["M"
IF %RGD?1.N1"-".N
Begin DoDot:2
+6 NEW %1,%2
+7 SET %1=+%RGD
SET %2=+$PIECE(%RGD,"-",2)
+8 if '%2
SET %2=%RGSCT
+9 if %1>%2
SET %RGD=%1
SET %1=%2
SET %2=%RGD
+10 if %2>%RGSCT
SET %2=%RGSCT
+11 FOR %=%1:1:%2
DO SLCT(%)
End DoDot:2
QUIT
+12 IF %RGOPT["X"
IF %RGOPT'["L"
SET (%RGSLCT,%RGD1,%RGIEN)=""
QUIT
+13 IF $EXTRACT(%RGD)="`"
Begin DoDot:2
+14 SET %RGD=+$EXTRACT(%RGD,2,999)
+15 IF $$VALD(%RGD)
DO DISV(%RGD)
SET %RGIEN=%RGD
End DoDot:2
QUIT
+16 SET %RGD1=%RGD1_";"_%RGD
End DoDot:1
if %RGSLCT=""
QUIT
+17 WRITE $$XY(0,%RGY+1),%RGEOS,!
+18 QUIT %RGIEN
+19 ; Add list selection to output
SLCT(%RGSLCT) ;
+1 IF %RGSLCT>0
IF %RGSLCT'>%RGSCT
Begin DoDot:1
+2 SET %RGIEN=+^TMP(%RGPID,+%RGSLCT)
+3 DO DISV(%RGIEN)
End DoDot:1
+4 QUIT
+5 ; Add IEN to output
DISV(%RGIEN) ;
+1 if %RGIEN=""
QUIT
+2 IF %RGMUL'=""
IF '$DATA(@%RGMUL@(%RGIEN))
SET @%RGMUL@(%RGIEN)=""
if '%RGQUIET
DO APP(%RGIEN)
+3 if %RGMUL=""
DO APP(%RGIEN)
+4 if %RGOPT(0)["F"
QUIT
+5 if %RGSAME
KILL ^DISV(DUZ,%RGDISV)
+6 SET %RGSAME=0
SET ^DISV(DUZ,%RGDISV)=%RGIEN
SET ^(%RGDISV,%RGIEN)=""
+7 QUIT
+8 ; Append primary key to key list
APP(%RGIEN) ;
+1 NEW %RGKEY
+2 SET %RGKEY=$SELECT(%RGIEN=+%RGIEN:$PIECE($GET(@%RGDIC@(%RGIEN,0)),U),1:%RGIEN)
+3 SET %RGKEY=$$FMT(%RGIEN,%RGKEY)
+4 if '$LENGTH(%RGKEY)!($LENGTH(%RGKEY)+$LENGTH(%RGD2)'<250)
QUIT
+5 SET %RGD2=%RGD2_$SELECT($LENGTH(%RGD2):";",1:"")_%RGKEY
+6 IF %RGOPT(0)'["J"
IF %RGOPT(0)'["M"
SET %RGD2=%RGD2_" "_$$SID(%RGIEN)
+7 QUIT
+8 ; Multi-term lookup
MTL NEW %
+1 SET %=$SELECT(%RGDIC[")":$TRANSLATE(%RGDIC,")",","),1:%RGDIC_"(")_"%RGXRF)"
+2 SET %=$$LKP^RGUTMTL(%,%RGD,"^TMP(""MTL"",%RGPID)",%RGOPT(0)[U)
+3 if %<0
SET %RGTRUNC=1
+4 if %
DO ADD(%RGPID,"^TMP","MTL")
+5 KILL ^TMP("MTL",%RGPID)
+6 QUIT
+7 ; Add key to selection list
ADD(%RGKEY,%RGIDX,%RGSUB) ;
+1 NEW %S
+2 if '$DATA(%RGIDX)
SET %RGIDX=%RGDIC
SET %RGSUB=%RGXRF
+3 FOR %S=0:0
SET %S=$ORDER(@%RGIDX@(%RGSUB,%RGKEY,%S))
if '%S
QUIT
Begin DoDot:1
+4 IF %RGOPT(0)["O"
IF $DATA(^TMP(%RGPID,0,%S))
QUIT
+5 IF $$VALD(%S)
Begin DoDot:2
+6 SET %RGSCT=%RGSCT+1
SET ^TMP(%RGPID,%RGSCT)=%S_U_$SELECT(%RGOPT(0)["W":"",1:%RGKEY)
SET ^(0,%S)=""
+7 IF %RGOPT(0)["S"
IF $GET(^DISV(DUZ,%RGDISV))=%S
SET %RGSLT=%RGSCT
End DoDot:2
End DoDot:1
+8 QUIT
+9 ; Check entry against screening criteria
VALD(%S) if '$DATA(@%RGDIC@(%S))!'%S
QUIT 0
+1 if %RGSCN=""
QUIT 1
+2 NEW %,%1
+3 SET %1=1
SET @$$TRAP^RGUTOS("V3^RGUTLK2")
+4 FOR %=0:0
SET %=$ORDER(@%RGSCN@(%))
if '%
QUIT
Begin DoDot:1
+5 SET %1=0
SET @$$TRAP^RGUTOS("V2^RGUTLK2")
+6 XECUTE "S %1="_@%RGSCN@(%)
V2 QUIT
End DoDot:1
if %1
QUIT
+1 QUIT %1
V3 QUIT 0
+1 ; Show the specified selection
SHOW(%RGSLCT,%RGCOL1,%RGCOL2) ;
+1 NEW %S,%Z,%P,%I
+2 SET %S=+%RGSLCT
SET %Z=$GET(@%RGDIC@(%S,0))
SET %P=$$FMT(%S,$SELECT(%RGOPT["I":$PIECE(%RGSLCT,U,2),1:$PIECE(%Z,U)))
+3 ;S %I=$$SID(%S,$P(%RGSLCT,U,2)),%I=$S(%I="":%P,1:%I)
+4 SET %I=$$SID(%S,%P)
SET %I=$SELECT(%I="":%P,1:%I)
+5 IF %RGHTML
Begin DoDot:1
+6 IF '%RGQUIET
WRITE $$MSG^RGUT(%RGPRMPT,"|"),!
+7 IF '$TEST
DO DISV(%S)
End DoDot:1
QUIT
+8 SET %RGCOL1=+$GET(%RGCOL1,$X)
+9 IF %RGOPT(0)["Y"
SET %RGCOL2=+$GET(%RGCOL2,IOM\%RGCOL+%RGCOL1-8-$LENGTH(%I))
+10 IF '$TEST
SET %RGCOL2=+$GET(%RGCOL2,IOM\%RGCOL\$SELECT(%RGOPT(0)["D":3,1:2)-3+%RGCOL1)
+11 WRITE $$XY(%RGCOL1,$Y)
+12 IF %RGOPT(0)'["J"
IF %I'=%P
WRITE $$TRUNC^RGUT(%P,IOM\%RGCOL-6),?%RGCOL2," "_$$TRUNC^RGUT(%I,IOM-%RGCOL2-2)
+13 IF '$TEST
WRITE $$TRUNC^RGUT(%I,IOM\%RGCOL-6)
+14 QUIT
+15 ; Return external form of result
FMT(%S,%RGKEY) ;
+1 if %RGKEY=""
QUIT %RGKEY
+2 IF %RGTRP'=""
IF $DATA(@%RGTRP@(%RGKEY))
QUIT @%RGTRP@(%RGKEY)
+3 if %RGOPT(0)["D"
SET %RGKEY=$$ENTRY^RGUTDT(%RGKEY)
+4 IF %RGOPT(0)["Z"
IF %RGSCN'=""
IF $GET(@%RGSCN)'=""
SET @("%RGKEY="_@%RGSCN)
+5 if %RGOPT["J"
SET %RGKEY=$$SID(%S,%RGKEY)
+6 QUIT %RGKEY
+7 ; Return secondary identifier
SID(%S,%RGKEY) ;
+1 SET %RGKEY=$GET(%RGKEY)
+2 NEW %Z
+3 SET %Z=$GET(@%RGDIC@(%S,0))
SET @("%Z="_$SELECT(%RGSID<0:$SELECT(%RGKEY=$$UP^XLFSTR($PIECE(%Z,U)):"""""",1:"%RGKEY"),%RGSID="":"%RGSID",1:%RGSID))
+4 QUIT %Z
+5 ; Partial key lookup
PARTIAL(%RGD,%RGKEY) ;
+1 NEW %,%1,%2
+2 SET (%(1),%(2))=0
SET %1(1)=%RGD
SET %1(2)=%RGKEY
+3 FOR %=1,2
SET %1(%)=$TRANSLATE(%1(%),".,;:?/!-"," ")
P1 SET (%2(1),%2(2))=""
+1 FOR %=1,2
Begin DoDot:1
+2 FOR %(%)=%(%)+1:1:$LENGTH(%1(%)," ")
SET %2(%)=$PIECE(%1(%)," ",%(%))
if %2(%)'=""
QUIT
End DoDot:1
+3 if %2(1)=""
QUIT 1
+4 if %2(1)'=$EXTRACT(%2(2),1,$LENGTH(%2(1)))
QUIT -(%(1)=1)
+5 GOTO P1
HELP(X) ; Application-specific help
+1 NEW %
+2 SET %=""
+3 FOR
SET %=$ORDER(X(%))
if %=""
QUIT
if $Y>20
DO PAUSE
WRITE $GET(X(%)),!
+4 QUIT
+5 ; Generic help
HELP1 NEW %
+1 WRITE !!
+2 if %RGHLP'=""
DO @%RGHLP
+3 WRITE !,"Enter a blank line for default action.",!
+4 if $Y>20
DO PAUSE
+5 if %RGOPT'["W"
WRITE "Enter ?? to see all possible selections.",!
+6 if $Y>20
DO PAUSE
+7 WRITE "Enter a space to retrieve previous selection.",!
+8 if $Y>20
DO PAUSE
+9 WRITE "Enter a valid identifier for lookup."
+10 if (%RGOPT'["*")&(%RGXRFS[U)
WRITE " Append a * to include all indices."
+11 WRITE !
+12 IF %RGOPT["M"
Begin DoDot:1
+13 if $Y>20
DO PAUSE
+14 WRITE "Separate multiple selections by semicolons."
End DoDot:1
+15 READ !!,"Press any key to continue...",*%:DTIME
+16 QUIT
+17 ; Help at choice prompt
HELP2 NEW %
+1 WRITE $$XY(0,16),%RGEOS,!
+2 WRITE $SELECT(%RGOPT(0)["K":"Enter N for next choices.",1:"Press RETURN for more choices.")
+3 WRITE ?35,"Enter B for previous choices.",!
+4 WRITE "Enter ^ to abort lookup.",?35,"Enter choice number to select.",!
+5 WRITE "Any other entry = new lookup."
+6 if %RGOPT(0)["M"
WRITE ?35,"Separate multiple selections by semicolons."
+7 READ !!,"Press any key to continue...",*%:DTIME
+8 QUIT
PAUSE NEW %
+1 READ !,"Press any key for more...",*%:DTIME
+2 WRITE $$XY(0,%RGY+2),%RGEOS
+3 QUIT
XY(X,Y) QUIT $SELECT(%RGRS:"",1:$$XY^RGUT(X,Y))
