- 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 Feb 19, 2025@00:03:52 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))
