CIAULKP ;MSC/IND/DKM - File lookup utility;14-Aug-2006 09:35;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Inputs:
; %CIADIC = Global root or file #
; %CIAOPT = 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
; %CIAPRMP = Prompt (optional)
; %CIAXRFS = Cross-references to examine (all "B"'s by default)
; %CIADATA = Data to lookup (optional)
; %CIASCN = Screening criteria (optional)
; %CIAMUL = Local variable or global reference to
; store multiple hits
; %CIAX = Column position for prompt (optional)
; %CIAY = Row position for prompt (optional)
; %CIASID = Piece # of secondary identifier (optional)
; or executable M code to display same
; %CIATRP = Special inputs to trap (optional)
; %CIAHLP = 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(%CIADIC,%CIAOPT,%CIAPRMP,%CIAXRFS,%CIADATA,%CIASCN,%CIAMUL,%CIAX,%CIAY,%CIASID,%CIATRP,%CIAHLP) ;
N %,%1,%N,%S,%Z,%CIAPID,%CIAXRF,%CIASCT,%CIAKEY,%CIAKEY1,%CIADISV,%CIASLCT
N %CIAXALL,%CIAXRN,%CIASMAX,%CIATRNC,%CIAD,%CIAD1,%CIAD2,%CIABEL,%CIANUM
N %CIADIR,%CIASLT,%CIACOL,%CIALAST,%CIASAME,%CIAEOS,%CIAEOL,%CIAHTML,%CIARS,%CIAQT
I $$NEWERR^%ZTER N $ET S $ET=""
S (%CIAOPT,%CIAOPT(0))=$$UP^XLFSTR($G(%CIAOPT)),%CIAPID="%CIALKP"_$J
S %CIABEL=$S(%CIAOPT["B":$C(7),1:""),%CIADIR=$S(%CIAOPT["R":-1,1:1)
S %CIASLT=1,%CIACOL=1,%CIAEOS=$C(27,91,74),%CIAEOL=$C(27,91,75),%CIAHTML=0
S %CIAX=$G(%CIAX,0),%CIAY=$G(%CIAY,3),DTIME=$G(DTIME,99999999)
S %CIALAST=0,%CIARS=%CIAOPT["C",%CIAQT=%CIAOPT["Q"
S:%CIARS %CIAEOS="",%CIAY=$Y
S:%CIAQT %CIAOPT=%CIAOPT_"XHM"
S:%CIAOPT["H" (%CIABEL,%CIAEOL,%CIAEOS)="",%CIAOPT=%CIAOPT_"X",%CIAHTML=1
S:%CIAOPT["L" %CIAOPT=%CIAOPT_"X"
S U="^",DUZ=$G(DUZ,0),IO=$G(IO,$I),IOM=$G(IOM,80),%CIAMUL=$G(%CIAMUL),%CIAHLP=$G(%CIAHLP),%CIATRP=$G(%CIATRP),%CIASCN=$G(%CIASCN),%CIASAME=%CIAOPT["M"&(%CIAMUL'="")
F %=2:1:9 S:%CIAOPT[% %CIACOL=%
S:%CIAOPT'["M" %CIAMUL=""
K:%CIAMUL'="" @%CIAMUL
S:%CIADIC=+%CIADIC %CIADIC=$$ROOT^DILFD(%CIADIC)
S:$E(%CIADIC,$L(%CIADIC))="(" %CIADIC=$E(%CIADIC,1,$L(%CIADIC)-1)
S:$E(%CIADIC,$L(%CIADIC))="," %CIADIC=$E(%CIADIC,1,$L(%CIADIC)-1)
I %CIADIC["(",$E(%CIADIC,$L(%CIADIC))'=")" S %CIADIC=%CIADIC_")"
S %CIAPRMP=$G(%CIAPRMP,$S(%CIAOPT["X":"",1:"Enter identifier: "))
S %CIADISV=$S(%CIADIC[")":$TR(%CIADIC,")",","),1:%CIADIC_"(")_$S(%CIAOPT["V":";"_%CIAPRMP,1:"")
S %CIASID=$G(%CIASID),%CIAXRFS=$G(%CIAXRFS),%CIADATA=$G(%CIADATA)
S:%CIASID=+%CIASID %CIASID=$S(%CIASID<0:%CIASID,1:"$P(%Z,U,"_%CIASID_")")
W:'%CIAHTML $$XY(%CIAX,%CIAY),%CIAEOS,!
I %CIAOPT["G",$G(^DISV(DUZ,%CIADISV))'="" D
.S %CIADATA=^(%CIADISV)
.S:+%CIADATA=%CIADATA %CIADATA=$P($G(@%CIADIC@(%CIADATA,0)),U)
I %CIAXRFS="" D
.S (%,%CIAXRFS)="B"
.F S %=$O(@%CIADIC@(%)) Q:$E(%)'="B" S %CIAXRFS=%CIAXRFS_U_%
F %=1:1:$L(%CIAXRFS,U) S %1=$P(%CIAXRFS,U,%) S:%1'="" %CIAXRFS($P(%1,":"))=$P(%1,":",2),$P(%CIAXRFS,U,%)=$P(%1,":")
S (%CIAD1,%CIAD2)=""
D RM(0)
S %CIAIEN=$$INPUT
W:'%CIAHTML $$XY(%CIAX+$L(%CIAPRMP),%CIAY),$$TRUNC^CIAU(%CIAD2,IOM-$X),%CIAEOS
D RM(IOM)
K ^TMP(%CIAPID)
Q %CIAIEN
INPUT() ;
INP K ^TMP(%CIAPID)
D READ
S:%CIAOPT["U" %CIAD=$$UP^XLFSTR(%CIAD)
S @$$TRAP^CIAUOS("ERROR^CIAULKP")
I %CIAD="",%CIATRP'="" S %CIAD=$G(@%CIATRP@(" "))
Q:"^^"[%CIAD -$L(%CIAD)
I "?"[%CIAD D HELP1^CIAULK2 G INP
I %CIAD=" " D SAME G:%CIAD="" INP2
I %CIATRP'="",$D(@%CIATRP@(%CIAD)) D Q %CIAD
.S %CIASAME=1
.D:%CIAOPT'["T" DISV^CIAULK2(%CIAD)
.S %CIAD2=$G(@%CIATRP@(%CIAD))
.S:%CIAD2="" %CIAD2=%CIAD
S:%CIAD="??" %CIAD=""
I $E(%CIAD,$L(%CIAD))="*" S %CIAXALL=1,%CIAD=$E(%CIAD,1,$L(%CIAD)-1)
E S %CIAXALL=%CIAOPT["*"
S %CIAIEN=$$LKP^CIAULK2(%CIAD)
INP2 G INP:%CIAIEN=""!$L(%CIAD1)
Q %CIAIEN
READ S %CIAD=""
F Q:%CIAD'=""!(%CIAD1="") S %CIAD=$P(%CIAD1,";"),%CIAD1=$P(%CIAD1,";",2,999)
Q:$L(%CIAD)
S %CIAD=%CIADATA,%CIADATA=""
W:'%CIAHTML $$XY(0,%CIAY+2),%CIAEOS,$$XY(%CIAX,%CIAY),%CIAPRMP_%CIAEOL
I %CIAOPT["X" S:%CIAOPT["E" %CIAOPT=$TR(%CIAOPT,"X"),%CIADATA=%CIAD Q
I %CIAOPT["E" D
.N %,%1
.S:%CIAD?1"`"1.N %CIAD=+$E(%CIAD,2,99),%CIAD=$$FMT^CIAULK2(%CIAD,$P($G(@%CIADIC@(%CIAD,0)),U))
.S %1=0,%=%CIAX+$L(%CIAPRMP),%=$$ENTRY^CIAUEDT(%CIAD,IOM-%-1,%,%CIAY,"","RHV",,,,,.%1)
.S:%1=3 %=U
.S:%="?" %CIADATA=%CIAD
.S %CIAD=%
E I '$L(%CIAD) R %CIAD:DTIME S:'$T %CIAD=U
I %CIAOPT["M",%CIAD[";" S %CIAD1=%CIAD G READ
Q
SAME S %CIASAME=0,%CIAIEN="",%CIAD="",%CIASCT=0
I %CIAMUL'="" D
.S %=""
.F S %=$O(^DISV(DUZ,%CIADISV,%)) Q:%="" D SM1
E S %=$G(^DISV(DUZ,%CIADISV)) D:%'="" SM1
S:%CIAHTML %CIAIEN=%CIASCT
Q
SM1 I %CIATRP'="",$D(@%CIATRP@(%)) S %CIAIEN=%,%CIAD=%
E I $$VALD^CIAULK2(%) S %CIAIEN=%
I D DISV^CIAULK2(%CIAIEN) S %CIASCT=%CIASCT+1
Q
XY(X,Y) Q $$XY^CIAULK2(.X,.Y)
RM(X) X ^%ZOSF("RM")
Q
ERROR W:'%CIAHTML $$XY(0,%CIAY+1),*7,%CIAEOL,$$EC^%ZOSV
S (%CIADATA,%CIAD1,%CIAD2)=""
G INP
CIAULKP ;MSC/IND/DKM - File lookup utility;14-Aug-2006 09:35;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Inputs:
+5 ; %CIADIC = Global root or file #
+6 ; %CIAOPT = Options
+7 ; A allow automatic selection of exact match
+8 ; B sound bell with selection prompt
+9 ; C use roll & scroll mode
+10 ; D index is in date/time format
+11 ; E use line editor
+12 ; F forget the entry (i.e., ^DISV not updated)
+13 ; G start with prior entry
+14 ; H HTML-formatted output
+15 ; I show only lookup identifiers
+16 ; J show only secondary identifiers
+17 ; K null entry at select prompt exits
+18 ; L like X, but allows lookup at select prompt
+19 ; M allow multiple selection
+20 ; O show entry only once
+21 ; P partial lookup
+22 ; Q silent lookup
+23 ; R reverse search through indices
+24 ; S start selection list at last selection
+25 ; T forget trapped inputs
+26 ; U force uppercase translation
+27 ; V extended DISV recall (prompt-specific)
+28 ; W use multi-term lookup algorithm
+29 ; X do not prompt for input
+30 ; Y right justify secondary identifiers
+31 ; Z perform special formatting of output
+32 ; 1 automatic selection if one match only
+33 ; 2-9 # of columns for selection display (default=1)
+34 ; * force all indices to be searched
+35 ; ^ allow search to be aborted
+36 ; %CIAPRMP = Prompt (optional)
+37 ; %CIAXRFS = Cross-references to examine (all "B"'s by default)
+38 ; %CIADATA = Data to lookup (optional)
+39 ; %CIASCN = Screening criteria (optional)
+40 ; %CIAMUL = Local variable or global reference to
+41 ; store multiple hits
+42 ; %CIAX = Column position for prompt (optional)
+43 ; %CIAY = Row position for prompt (optional)
+44 ; %CIASID = Piece # of secondary identifier (optional)
+45 ; or executable M code to display same
+46 ; %CIATRP = Special inputs to trap (optional)
+47 ; %CIAHLP = Entry point to invoke help
+48 ; Outputs:
+49 ; Return value = index of selected entry or:
+50 ; -1 for forced exit by ^
+51 ; -2 for forced exit by ^^
+52 ; 0 for null entry
+53 ;=================================================================
ENTRY(%CIADIC,%CIAOPT,%CIAPRMP,%CIAXRFS,%CIADATA,%CIASCN,%CIAMUL,%CIAX,%CIAY,%CIASID,%CIATRP,%CIAHLP) ;
+1 NEW %,%1,%N,%S,%Z,%CIAPID,%CIAXRF,%CIASCT,%CIAKEY,%CIAKEY1,%CIADISV,%CIASLCT
+2 NEW %CIAXALL,%CIAXRN,%CIASMAX,%CIATRNC,%CIAD,%CIAD1,%CIAD2,%CIABEL,%CIANUM
+3 NEW %CIADIR,%CIASLT,%CIACOL,%CIALAST,%CIASAME,%CIAEOS,%CIAEOL,%CIAHTML,%CIARS,%CIAQT
+4 IF $$NEWERR^%ZTER
NEW $ETRAP
SET $ETRAP=""
+5 SET (%CIAOPT,%CIAOPT(0))=$$UP^XLFSTR($GET(%CIAOPT))
SET %CIAPID="%CIALKP"_$JOB
+6 SET %CIABEL=$SELECT(%CIAOPT["B":$CHAR(7),1:"")
SET %CIADIR=$SELECT(%CIAOPT["R":-1,1:1)
+7 SET %CIASLT=1
SET %CIACOL=1
SET %CIAEOS=$CHAR(27,91,74)
SET %CIAEOL=$CHAR(27,91,75)
SET %CIAHTML=0
+8 SET %CIAX=$GET(%CIAX,0)
SET %CIAY=$GET(%CIAY,3)
SET DTIME=$GET(DTIME,99999999)
+9 SET %CIALAST=0
SET %CIARS=%CIAOPT["C"
SET %CIAQT=%CIAOPT["Q"
+10 IF %CIARS
SET %CIAEOS=""
SET %CIAY=$Y
+11 IF %CIAQT
SET %CIAOPT=%CIAOPT_"XHM"
+12 IF %CIAOPT["H"
SET (%CIABEL,%CIAEOL,%CIAEOS)=""
SET %CIAOPT=%CIAOPT_"X"
SET %CIAHTML=1
+13 IF %CIAOPT["L"
SET %CIAOPT=%CIAOPT_"X"
+14 SET U="^"
SET DUZ=$GET(DUZ,0)
SET IO=$GET(IO,$IO)
SET IOM=$GET(IOM,80)
SET %CIAMUL=$GET(%CIAMUL)
SET %CIAHLP=$GET(%CIAHLP)
SET %CIATRP=$GET(%CIATRP)
SET %CIASCN=$GET(%CIASCN)
SET %CIASAME=%CIAOPT["M"&(%CIAMUL'="")
+15 FOR %=2:1:9
IF %CIAOPT[%
SET %CIACOL=%
+16 IF %CIAOPT'["M"
SET %CIAMUL=""
+17 IF %CIAMUL'=""
KILL @%CIAMUL
+18 IF %CIADIC=+%CIADIC
SET %CIADIC=$$ROOT^DILFD(%CIADIC)
+19 IF $EXTRACT(%CIADIC,$LENGTH(%CIADIC))="("
SET %CIADIC=$EXTRACT(%CIADIC,1,$LENGTH(%CIADIC)-1)
+20 IF $EXTRACT(%CIADIC,$LENGTH(%CIADIC))=","
SET %CIADIC=$EXTRACT(%CIADIC,1,$LENGTH(%CIADIC)-1)
+21 IF %CIADIC["("
IF $EXTRACT(%CIADIC,$LENGTH(%CIADIC))'=")"
SET %CIADIC=%CIADIC_")"
+22 SET %CIAPRMP=$GET(%CIAPRMP,$SELECT(%CIAOPT["X":"",1:"Enter identifier: "))
+23 SET %CIADISV=$SELECT(%CIADIC[")":$TRANSLATE(%CIADIC,")",","),1:%CIADIC_"(")_$SELECT(%CIAOPT["V":";"_%CIAPRMP,1:"")
+24 SET %CIASID=$GET(%CIASID)
SET %CIAXRFS=$GET(%CIAXRFS)
SET %CIADATA=$GET(%CIADATA)
+25 IF %CIASID=+%CIASID
SET %CIASID=$SELECT(%CIASID<0:%CIASID,1:"$P(%Z,U,"_%CIASID_")")
+26 IF '%CIAHTML
WRITE $$XY(%CIAX,%CIAY),%CIAEOS,!
+27 IF %CIAOPT["G"
IF $GET(^DISV(DUZ,%CIADISV))'=""
Begin DoDot:1
+28 SET %CIADATA=^(%CIADISV)
+29 IF +%CIADATA=%CIADATA
SET %CIADATA=$PIECE($GET(@%CIADIC@(%CIADATA,0)),U)
End DoDot:1
+30 IF %CIAXRFS=""
Begin DoDot:1
+31 SET (%,%CIAXRFS)="B"
+32 FOR
SET %=$ORDER(@%CIADIC@(%))
IF $EXTRACT(%)'="B"
QUIT
SET %CIAXRFS=%CIAXRFS_U_%
End DoDot:1
+33 FOR %=1:1:$LENGTH(%CIAXRFS,U)
SET %1=$PIECE(%CIAXRFS,U,%)
IF %1'=""
SET %CIAXRFS($PIECE(%1,":"))=$PIECE(%1,":",2)
SET $PIECE(%CIAXRFS,U,%)=$PIECE(%1,":")
+34 SET (%CIAD1,%CIAD2)=""
+35 DO RM(0)
+36 SET %CIAIEN=$$INPUT
+37 IF '%CIAHTML
WRITE $$XY(%CIAX+$LENGTH(%CIAPRMP),%CIAY),$$TRUNC^CIAU(%CIAD2,IOM-$X),%CIAEOS
+38 DO RM(IOM)
+39 KILL ^TMP(%CIAPID)
+40 QUIT %CIAIEN
INPUT() ;
INP KILL ^TMP(%CIAPID)
+1 DO READ
+2 IF %CIAOPT["U"
SET %CIAD=$$UP^XLFSTR(%CIAD)
+3 SET @$$TRAP^CIAUOS("ERROR^CIAULKP")
+4 IF %CIAD=""
IF %CIATRP'=""
SET %CIAD=$GET(@%CIATRP@(" "))
+5 IF "^^"[%CIAD
QUIT -$LENGTH(%CIAD)
+6 IF "?"[%CIAD
DO HELP1^CIAULK2
GOTO INP
+7 IF %CIAD=" "
DO SAME
IF %CIAD=""
GOTO INP2
+8 IF %CIATRP'=""
IF $DATA(@%CIATRP@(%CIAD))
Begin DoDot:1
+9 SET %CIASAME=1
+10 IF %CIAOPT'["T"
DO DISV^CIAULK2(%CIAD)
+11 SET %CIAD2=$GET(@%CIATRP@(%CIAD))
+12 IF %CIAD2=""
SET %CIAD2=%CIAD
End DoDot:1
QUIT %CIAD
+13 IF %CIAD="??"
SET %CIAD=""
+14 IF $EXTRACT(%CIAD,$LENGTH(%CIAD))="*"
SET %CIAXALL=1
SET %CIAD=$EXTRACT(%CIAD,1,$LENGTH(%CIAD)-1)
+15 IF '$TEST
SET %CIAXALL=%CIAOPT["*"
+16 SET %CIAIEN=$$LKP^CIAULK2(%CIAD)
INP2 IF %CIAIEN=""!$LENGTH(%CIAD1)
GOTO INP
+1 QUIT %CIAIEN
READ SET %CIAD=""
+1 FOR
IF %CIAD'=""!(%CIAD1="")
QUIT
SET %CIAD=$PIECE(%CIAD1,";")
SET %CIAD1=$PIECE(%CIAD1,";",2,999)
+2 IF $LENGTH(%CIAD)
QUIT
+3 SET %CIAD=%CIADATA
SET %CIADATA=""
+4 IF '%CIAHTML
WRITE $$XY(0,%CIAY+2),%CIAEOS,$$XY(%CIAX,%CIAY),%CIAPRMP_%CIAEOL
+5 IF %CIAOPT["X"
IF %CIAOPT["E"
SET %CIAOPT=$TRANSLATE(%CIAOPT,"X")
SET %CIADATA=%CIAD
QUIT
+6 IF %CIAOPT["E"
Begin DoDot:1
+7 NEW %,%1
+8 IF %CIAD?1"`"1.N
SET %CIAD=+$EXTRACT(%CIAD,2,99)
SET %CIAD=$$FMT^CIAULK2(%CIAD,$PIECE($GET(@%CIADIC@(%CIAD,0)),U))
+9 SET %1=0
SET %=%CIAX+$LENGTH(%CIAPRMP)
SET %=$$ENTRY^CIAUEDT(%CIAD,IOM-%-1,%,%CIAY,"","RHV",,,,,.%1)
+10 IF %1=3
SET %=U
+11 IF %="?"
SET %CIADATA=%CIAD
+12 SET %CIAD=%
End DoDot:1
+13 IF '$TEST
IF '$LENGTH(%CIAD)
READ %CIAD:DTIME
IF '$TEST
SET %CIAD=U
+14 IF %CIAOPT["M"
IF %CIAD[";"
SET %CIAD1=%CIAD
GOTO READ
+15 QUIT
SAME SET %CIASAME=0
SET %CIAIEN=""
SET %CIAD=""
SET %CIASCT=0
+1 IF %CIAMUL'=""
Begin DoDot:1
+2 SET %=""
+3 FOR
SET %=$ORDER(^DISV(DUZ,%CIADISV,%))
IF %=""
QUIT
DO SM1
End DoDot:1
+4 IF '$TEST
SET %=$GET(^DISV(DUZ,%CIADISV))
IF %'=""
DO SM1
+5 IF %CIAHTML
SET %CIAIEN=%CIASCT
+6 QUIT
SM1 IF %CIATRP'=""
IF $DATA(@%CIATRP@(%))
SET %CIAIEN=%
SET %CIAD=%
+1 IF '$TEST
IF $$VALD^CIAULK2(%)
SET %CIAIEN=%
+2 IF $TEST
DO DISV^CIAULK2(%CIAIEN)
SET %CIASCT=%CIASCT+1
+3 QUIT
XY(X,Y) QUIT $$XY^CIAULK2(.X,.Y)
RM(X) XECUTE ^%ZOSF("RM")
+1 QUIT
ERROR IF '%CIAHTML
WRITE $$XY(0,%CIAY+1),*7,%CIAEOL,$$EC^%ZOSV
+1 SET (%CIADATA,%CIAD1,%CIAD2)=""
+2 GOTO INP
