CIAULK2 ;MSC/IND/DKM - Continuation of CIAULKP;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
LKP(%CIADX) ;
N %CIAD,%CIAZ,%CIAN
S %CIAXRN=0,%CIATRNC=0,%CIAIEN="",%CIASCT=0,%CIAD=%CIADX
W:'%CIAHTML $$XY(%CIAX+$L(%CIAPRMP),%CIAY),$S(%CIAOPT["X":"",1:%CIAD),%CIAEOS,!,"Searching"_$S(%CIAOPT[U:" (press ^ to abort)",1:"")_"...",*13
I $E(%CIAD)="`" S %CIASLCT=%CIAD G:'%CIAHTML NR5 D SHOW($E(%CIAD,2,999)) Q 1
NXTREF S %CIAXRN=%CIAXRN+1,%CIAXRF=$P(%CIAXRFS,U,%CIAXRN),%CIAD=%CIADX
I %CIAXRF="" G:%CIASCT NR3 W:'%CIAHTML *7,*13,%CIAEOL,"Not found"_$S(%CIAD="":".",1:": ")_$S(%CIAD'=+%CIAD:%CIAD,%CIAOPT["D":$$ENTRY^CIAUDT(%CIAD),1:%CIAD) S %CIAD1=$S(%CIAOPT["X":U,1:"") Q ""
S %CIAOPT(0)=%CIAOPT_%CIAXRFS(%CIAXRF)
I %CIAOPT(0)["D",$L(%CIADX) D G:%CIAD<1 NXTREF
.S %CIAD=$$DT^CIAU(%CIADX)
I %CIAOPT(0)["W" D MTL G NXTREF
S %CIAKEY=$S(%CIAOPT(0)["P":$P(%CIAD," "),1:%CIAD)_$S(%CIADIR<0:$C(255),1:""),%CIANUM=$S(%CIAKEY=+%CIAKEY:%CIAKEY,1:"")
I %CIAD'="",$D(@%CIADIC@(%CIAXRF,%CIAD)) S %=%CIASCT+1 D ADD(%CIAD) I %CIASCT=%,%CIAOPT(0)["A" D SLCT(%CIASCT) Q %CIAIEN
NR2 I %CIAOPT(0)[U R %#1:0 I %=U S %CIATRNC=1 G NR3:%CIASCT Q ""
S %CIAKEY=$O(@%CIADIC@(%CIAXRF,%CIAKEY),%CIADIR)
I (%CIANUM="")=(%CIAKEY=+%CIAKEY),%CIAD'="" S %CIAKEY=""
I %CIAKEY'="",%CIAOPT(0)["P",%CIAKEY'=%CIAD S %=$$PARTIAL(%CIAD,%CIAKEY) D ADD(%CIAKEY):%>0 G:%'<0 NR2:%CIASCT<100
I %CIAKEY'="",%CIAOPT(0)'["P",$E(%CIAKEY,1,$L(%CIAD))=%CIAD D ADD(%CIAKEY) G:%CIASCT<100 NR2
I %CIANUM'="" S %CIAKEY=%CIANUM_$C($S(%CIADIR<0:255,1:1)),%CIANUM="" G NR2
I %CIASCT'<100 W:'%CIAHTML *7 S %CIAXALL=0,%CIATRNC=1
G:'%CIASCT!%CIAXALL NXTREF
NR3 I %CIASCT=1,%CIAOPT(0)[1,'%CIATRNC D SLCT(1) Q %CIAIEN
S %CIAKEY=%CIASLT,%CIASLT=1,%CIASMAX=$S(%CIAHTML!%CIARS:99999,1:17-%CIAY)
NR4 W:'%CIAHTML $$XY(0,%CIAY+1),%CIAEOS,!
F %CIAN=%CIAKEY:1:%CIAKEY+%CIASMAX-1 D Q:%CIAN=%CIASCT
.F %CIAZ=0:1:%CIACOL-1 D
..S %1=IOM/%CIACOL*%CIAZ\1,%CIALAST=%CIAZ*%CIASMAX+%CIAN
..Q:%CIALAST>%CIASCT
..W:'%CIAHTML $$XY(%1,$Y),%CIAEOL,%CIALAST,?5
..D SHOW(^TMP(%CIAPID,%CIALAST),%1+4)
.W:'%CIAQT !
Q:%CIAHTML $S(%CIATRNC:-%CIASCT,1:%CIASCT)
W:%CIALAST<%CIASCT !,%CIASCT-%CIALAST," more choice(s)..."
W:%CIATRNC " (list was truncated)",!
W %CIAEOS_%CIABEL,!!
R "Enter selection: ",%CIASLCT:DTIME
S:'$T %CIASLCT=U
W *13
I %CIAOPT["K",%CIASLCT="" Q -1
I "Nn"[%CIASLCT S %CIAKEY=$S(%CIALAST<%CIASCT:%CIALAST+1,1:1) G NR4
I "Bb"[%CIASLCT S %CIAKEY=$S(%CIAKEY=1:%CIASCT-%CIASMAX+1,%CIAKEY'>%CIASMAX:1,1:%CIAKEY-%CIASMAX) S:%CIAKEY<1 %CIAKEY=1 G NR4
I "?"[%CIASLCT D HELP2 G NR4
I "^^"[%CIASLCT S %CIAD2="",%CIAD1=$S(%CIAOPT(0)["X":%CIASLCT,%CIASLCT="^^":%CIASLCT,1:"") Q ""
NR5 F D Q:%CIASLCT=""
.I %CIAOPT(0)["M" S %CIAD=$P(%CIASLCT,";"),%CIASLCT=$P(%CIASLCT,";",2,999)
.E S %CIAD=%CIASLCT,%CIASLCT=""
.Q:'$L(%CIAD)
.I %CIAD?1.N D SLCT(%CIAD) Q
.I %CIAOPT(0)["M",%CIAD?1.N1"-".N D Q
..N %1,%2
..S %1=+%CIAD,%2=+$P(%CIAD,"-",2)
..S:'%2 %2=%CIASCT
..S:%1>%2 %CIAD=%1,%1=%2,%2=%CIAD
..S:%2>%CIASCT %2=%CIASCT
..F %=%1:1:%2 D SLCT(%)
.I %CIAOPT["X",%CIAOPT'["L" S (%CIASLCT,%CIAD1,%CIAIEN)="" Q
.I $E(%CIAD)="`" D Q
..S %CIAD=+$E(%CIAD,2,999)
..I $$VALD(%CIAD) D DISV(%CIAD) S %CIAIEN=%CIAD
.S %CIAD1=%CIAD1_";"_%CIAD
W $$XY(0,%CIAY+1),%CIAEOS,!
Q %CIAIEN
; Add list selection to output
SLCT(%CIASLCT) ;
I %CIASLCT>0,%CIASLCT'>%CIASCT D
.S %CIAIEN=+^TMP(%CIAPID,+%CIASLCT)
.D DISV(%CIAIEN)
Q
; Add IEN to output
DISV(%CIAIEN) ;
Q:%CIAIEN=""
I %CIAMUL'="",'$D(@%CIAMUL@(%CIAIEN)) S @%CIAMUL@(%CIAIEN)="" D:'%CIAQT APP(%CIAIEN)
D:%CIAMUL="" APP(%CIAIEN)
Q:%CIAOPT(0)["F"
K:%CIASAME ^DISV(DUZ,%CIADISV)
S %CIASAME=0,^DISV(DUZ,%CIADISV)=%CIAIEN,^(%CIADISV,%CIAIEN)=""
Q
; Append primary key to key list
APP(%CIAIEN) ;
N %CIAKEY
S %CIAKEY=$S(%CIAIEN=+%CIAIEN:$P($G(@%CIADIC@(%CIAIEN,0)),U),1:%CIAIEN)
S %CIAKEY=$$FMT(%CIAIEN,%CIAKEY)
Q:'$L(%CIAKEY)!($L(%CIAKEY)+$L(%CIAD2)'<250)
S %CIAD2=%CIAD2_$S($L(%CIAD2):";",1:"")_%CIAKEY
I %CIAOPT(0)'["J",%CIAOPT(0)'["M" S %CIAD2=%CIAD2_" "_$$SID(%CIAIEN)
Q
; Multi-term lookup
MTL N %
S %=$S(%CIADIC[")":$TR(%CIADIC,")",","),1:%CIADIC_"(")_"%CIAXRF)"
S %=$$LKP^CIAUMTL(%,%CIAD,"^TMP(""MTL"",%CIAPID)",%CIAOPT(0)[U)
S:%<0 %CIATRNC=1
D:% ADD(%CIAPID,"^TMP","MTL")
K ^TMP("MTL",%CIAPID)
Q
; Add key to selection list
ADD(%CIAKEY,%CIAIDX,%CIASUB) ;
N %S
S:'$D(%CIAIDX) %CIAIDX=%CIADIC,%CIASUB=%CIAXRF
F %S=0:0 S %S=$O(@%CIAIDX@(%CIASUB,%CIAKEY,%S)) Q:'%S D
.I %CIAOPT(0)["O",$D(^TMP(%CIAPID,0,%S)) Q
.I $$VALD(%S) D
..S %CIASCT=%CIASCT+1,^TMP(%CIAPID,%CIASCT)=%S_U_$S(%CIAOPT(0)["W":"",1:%CIAKEY),^(0,%S)=""
..I %CIAOPT(0)["S",$G(^DISV(DUZ,%CIADISV))=%S S %CIASLT=%CIASCT
Q
; Check entry against screening criteria
VALD(%S) Q:'$D(@%CIADIC@(%S))!'%S 0
Q:%CIASCN="" 1
N %,%1
S %1=1,@$$TRAP^CIAUOS("V3^CIAULK2")
F %=0:0 S %=$O(@%CIASCN@(%)) Q:'% D Q:%1
.S %1=0,@$$TRAP^CIAUOS("V2^CIAULK2")
.X "S %1="_@%CIASCN@(%)
V2 .Q
Q %1
V3 Q 0
; Show the specified selection
SHOW(%CIASLCT,%CIACOL1,%CIACOL2) ;
N %S,%Z,%P,%I
S %S=+%CIASLCT,%Z=$G(@%CIADIC@(%S,0)),%P=$$FMT(%S,$S(%CIAOPT["I":$P(%CIASLCT,U,2),1:$P(%Z,U)))
;S %I=$$SID(%S,$P(%CIASLCT,U,2)),%I=$S(%I="":%P,1:%I)
S %I=$$SID(%S,%P),%I=$S(%I="":%P,1:%I)
I %CIAHTML D Q
.I '%CIAQT W $$MSG^CIAU(%CIAPRMP,"|"),!
.E D DISV(%S)
S %CIACOL1=+$G(%CIACOL1,$X)
I %CIAOPT(0)["Y" S %CIACOL2=+$G(%CIACOL2,IOM\%CIACOL+%CIACOL1-8-$L(%I))
E S %CIACOL2=+$G(%CIACOL2,IOM\%CIACOL\$S(%CIAOPT(0)["D":3,1:2)-3+%CIACOL1)
W $$XY(%CIACOL1,$Y)
I %CIAOPT(0)'["J",%I'=%P W $$TRUNC^CIAU(%P,IOM\%CIACOL-6),?%CIACOL2," "_$$TRUNC^CIAU(%I,IOM-%CIACOL2-2)
E W $$TRUNC^CIAU(%I,IOM\%CIACOL-6)
Q
; Return external form of result
FMT(%S,%CIAKEY) ;
Q:%CIAKEY="" %CIAKEY
I %CIATRP'="",$D(@%CIATRP@(%CIAKEY)) Q @%CIATRP@(%CIAKEY)
S:%CIAOPT(0)["D" %CIAKEY=$$ENTRY^CIAUDT(%CIAKEY)
I %CIAOPT(0)["Z",%CIASCN'="",$G(@%CIASCN)'="" S @("%CIAKEY="_@%CIASCN)
S:%CIAOPT["J" %CIAKEY=$$SID(%S,%CIAKEY)
Q %CIAKEY
; Return secondary identifier
SID(%S,%CIAKEY) ;
S %CIAKEY=$G(%CIAKEY)
N %Z
S %Z=$G(@%CIADIC@(%S,0)),@("%Z="_$S(%CIASID<0:$S(%CIAKEY=$$UP^XLFSTR($P(%Z,U)):"""""",1:"%CIAKEY"),%CIASID="":"%CIASID",1:%CIASID))
Q %Z
; Partial key lookup
PARTIAL(%CIAD,%CIAKEY) ;
N %,%1,%2
S (%(1),%(2))=0,%1(1)=%CIAD,%1(2)=%CIAKEY
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:%CIAHLP'="" @%CIAHLP
W !,"Enter a blank line for default action.",!
D:$Y>20 PAUSE
W:%CIAOPT'["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:(%CIAOPT'["*")&(%CIAXRFS[U) " Append a * to include all indices."
W !
I %CIAOPT["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),%CIAEOS,!
W $S(%CIAOPT(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:%CIAOPT(0)["M" ?35,"Separate multiple selections by semicolons."
R !!,"Press any key to continue...",*%:DTIME
Q
PAUSE Q:%CIARS
N %
R !,"Press any key for more...",*%:DTIME
W $$XY(0,%CIAY+2),%CIAEOS
Q
XY(X,Y) ;I %CIARS W:'X *13 S $X=X,$Y=Y Q ""
S:%CIARS Y=$Y
Q $$XY^CIAU(X,Y)
CIAULK2 ;MSC/IND/DKM - Continuation of CIAULKP;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
LKP(%CIADX) ;
+1 NEW %CIAD,%CIAZ,%CIAN
+2 SET %CIAXRN=0
SET %CIATRNC=0
SET %CIAIEN=""
SET %CIASCT=0
SET %CIAD=%CIADX
+3 IF '%CIAHTML
WRITE $$XY(%CIAX+$LENGTH(%CIAPRMP),%CIAY),$SELECT(%CIAOPT["X":"",1:%CIAD),%CIAEOS,!,"Searching"_$SELECT(%CIAOPT[U:" (press ^ to abort)",1:"")_"...",*13
+4 IF $EXTRACT(%CIAD)="`"
SET %CIASLCT=%CIAD
IF '%CIAHTML
GOTO NR5
DO SHOW($EXTRACT(%CIAD,2,999))
QUIT 1
NXTREF SET %CIAXRN=%CIAXRN+1
SET %CIAXRF=$PIECE(%CIAXRFS,U,%CIAXRN)
SET %CIAD=%CIADX
+1 IF %CIAXRF=""
IF %CIASCT
GOTO NR3
IF '%CIAHTML
WRITE *7,*13,%CIAEOL,"Not found"_$SELECT(%CIAD="":".",1:": ")_$SELECT(%CIAD'=+%CIAD:%CIAD,%CIAOPT["D":$$ENTRY^CIAUDT(%CIAD),1:%CIAD)
SET %CIAD1=$SELECT(%CIAOPT["X":U,1:"")
QUIT ""
+2 SET %CIAOPT(0)=%CIAOPT_%CIAXRFS(%CIAXRF)
+3 IF %CIAOPT(0)["D"
IF $LENGTH(%CIADX)
Begin DoDot:1
+4 SET %CIAD=$$DT^CIAU(%CIADX)
End DoDot:1
IF %CIAD<1
GOTO NXTREF
+5 IF %CIAOPT(0)["W"
DO MTL
GOTO NXTREF
+6 SET %CIAKEY=$SELECT(%CIAOPT(0)["P":$PIECE(%CIAD," "),1:%CIAD)_$SELECT(%CIADIR<0:$CHAR(255),1:"")
SET %CIANUM=$SELECT(%CIAKEY=+%CIAKEY:%CIAKEY,1:"")
+7 IF %CIAD'=""
IF $DATA(@%CIADIC@(%CIAXRF,%CIAD))
SET %=%CIASCT+1
DO ADD(%CIAD)
IF %CIASCT=%
IF %CIAOPT(0)["A"
DO SLCT(%CIASCT)
QUIT %CIAIEN
NR2 IF %CIAOPT(0)[U
READ %#1:0
IF %=U
SET %CIATRNC=1
IF %CIASCT
GOTO NR3
QUIT ""
+1 SET %CIAKEY=$ORDER(@%CIADIC@(%CIAXRF,%CIAKEY),%CIADIR)
+2 IF (%CIANUM="")=(%CIAKEY=+%CIAKEY)
IF %CIAD'=""
SET %CIAKEY=""
+3 IF %CIAKEY'=""
IF %CIAOPT(0)["P"
IF %CIAKEY'=%CIAD
SET %=$$PARTIAL(%CIAD,%CIAKEY)
IF %>0
DO ADD(%CIAKEY)
IF %'<0
IF %CIASCT<100
GOTO NR2
+4 IF %CIAKEY'=""
IF %CIAOPT(0)'["P"
IF $EXTRACT(%CIAKEY,1,$LENGTH(%CIAD))=%CIAD
DO ADD(%CIAKEY)
IF %CIASCT<100
GOTO NR2
+5 IF %CIANUM'=""
SET %CIAKEY=%CIANUM_$CHAR($SELECT(%CIADIR<0:255,1:1))
SET %CIANUM=""
GOTO NR2
+6 IF %CIASCT'<100
IF '%CIAHTML
WRITE *7
SET %CIAXALL=0
SET %CIATRNC=1
+7 IF '%CIASCT!%CIAXALL
GOTO NXTREF
NR3 IF %CIASCT=1
IF %CIAOPT(0)[1
IF '%CIATRNC
DO SLCT(1)
QUIT %CIAIEN
+1 SET %CIAKEY=%CIASLT
SET %CIASLT=1
SET %CIASMAX=$SELECT(%CIAHTML!%CIARS:99999,1:17-%CIAY)
NR4 IF '%CIAHTML
WRITE $$XY(0,%CIAY+1),%CIAEOS,!
+1 FOR %CIAN=%CIAKEY:1:%CIAKEY+%CIASMAX-1
Begin DoDot:1
+2 FOR %CIAZ=0:1:%CIACOL-1
Begin DoDot:2
+3 SET %1=IOM/%CIACOL*%CIAZ\1
SET %CIALAST=%CIAZ*%CIASMAX+%CIAN
+4 IF %CIALAST>%CIASCT
QUIT
+5 IF '%CIAHTML
WRITE $$XY(%1,$Y),%CIAEOL,%CIALAST,?5
+6 DO SHOW(^TMP(%CIAPID,%CIALAST),%1+4)
End DoDot:2
+7 IF '%CIAQT
WRITE !
End DoDot:1
IF %CIAN=%CIASCT
QUIT
+8 IF %CIAHTML
QUIT $SELECT(%CIATRNC:-%CIASCT,1:%CIASCT)
+9 IF %CIALAST<%CIASCT
WRITE !,%CIASCT-%CIALAST," more choice(s)..."
+10 IF %CIATRNC
WRITE " (list was truncated)",!
+11 WRITE %CIAEOS_%CIABEL,!!
+12 READ "Enter selection: ",%CIASLCT:DTIME
+13 IF '$TEST
SET %CIASLCT=U
+14 WRITE *13
+15 IF %CIAOPT["K"
IF %CIASLCT=""
QUIT -1
+16 IF "Nn"[%CIASLCT
SET %CIAKEY=$SELECT(%CIALAST<%CIASCT:%CIALAST+1,1:1)
GOTO NR4
+17 IF "Bb"[%CIASLCT
SET %CIAKEY=$SELECT(%CIAKEY=1:%CIASCT-%CIASMAX+1,%CIAKEY'>%CIASMAX:1,1:%CIAKEY-%CIASMAX)
IF %CIAKEY<1
SET %CIAKEY=1
GOTO NR4
+18 IF "?"[%CIASLCT
DO HELP2
GOTO NR4
+19 IF "^^"[%CIASLCT
SET %CIAD2=""
SET %CIAD1=$SELECT(%CIAOPT(0)["X":%CIASLCT,%CIASLCT="^^":%CIASLCT,1:"")
QUIT ""
NR5 FOR
Begin DoDot:1
+1 IF %CIAOPT(0)["M"
SET %CIAD=$PIECE(%CIASLCT,";")
SET %CIASLCT=$PIECE(%CIASLCT,";",2,999)
+2 IF '$TEST
SET %CIAD=%CIASLCT
SET %CIASLCT=""
+3 IF '$LENGTH(%CIAD)
QUIT
+4 IF %CIAD?1.N
DO SLCT(%CIAD)
QUIT
+5 IF %CIAOPT(0)["M"
IF %CIAD?1.N1"-".N
Begin DoDot:2
+6 NEW %1,%2
+7 SET %1=+%CIAD
SET %2=+$PIECE(%CIAD,"-",2)
+8 IF '%2
SET %2=%CIASCT
+9 IF %1>%2
SET %CIAD=%1
SET %1=%2
SET %2=%CIAD
+10 IF %2>%CIASCT
SET %2=%CIASCT
+11 FOR %=%1:1:%2
DO SLCT(%)
End DoDot:2
QUIT
+12 IF %CIAOPT["X"
IF %CIAOPT'["L"
SET (%CIASLCT,%CIAD1,%CIAIEN)=""
QUIT
+13 IF $EXTRACT(%CIAD)="`"
Begin DoDot:2
+14 SET %CIAD=+$EXTRACT(%CIAD,2,999)
+15 IF $$VALD(%CIAD)
DO DISV(%CIAD)
SET %CIAIEN=%CIAD
End DoDot:2
QUIT
+16 SET %CIAD1=%CIAD1_";"_%CIAD
End DoDot:1
IF %CIASLCT=""
QUIT
+17 WRITE $$XY(0,%CIAY+1),%CIAEOS,!
+18 QUIT %CIAIEN
+19 ; Add list selection to output
SLCT(%CIASLCT) ;
+1 IF %CIASLCT>0
IF %CIASLCT'>%CIASCT
Begin DoDot:1
+2 SET %CIAIEN=+^TMP(%CIAPID,+%CIASLCT)
+3 DO DISV(%CIAIEN)
End DoDot:1
+4 QUIT
+5 ; Add IEN to output
DISV(%CIAIEN) ;
+1 IF %CIAIEN=""
QUIT
+2 IF %CIAMUL'=""
IF '$DATA(@%CIAMUL@(%CIAIEN))
SET @%CIAMUL@(%CIAIEN)=""
IF '%CIAQT
DO APP(%CIAIEN)
+3 IF %CIAMUL=""
DO APP(%CIAIEN)
+4 IF %CIAOPT(0)["F"
QUIT
+5 IF %CIASAME
KILL ^DISV(DUZ,%CIADISV)
+6 SET %CIASAME=0
SET ^DISV(DUZ,%CIADISV)=%CIAIEN
SET ^(%CIADISV,%CIAIEN)=""
+7 QUIT
+8 ; Append primary key to key list
APP(%CIAIEN) ;
+1 NEW %CIAKEY
+2 SET %CIAKEY=$SELECT(%CIAIEN=+%CIAIEN:$PIECE($GET(@%CIADIC@(%CIAIEN,0)),U),1:%CIAIEN)
+3 SET %CIAKEY=$$FMT(%CIAIEN,%CIAKEY)
+4 IF '$LENGTH(%CIAKEY)!($LENGTH(%CIAKEY)+$LENGTH(%CIAD2)'<250)
QUIT
+5 SET %CIAD2=%CIAD2_$SELECT($LENGTH(%CIAD2):";",1:"")_%CIAKEY
+6 IF %CIAOPT(0)'["J"
IF %CIAOPT(0)'["M"
SET %CIAD2=%CIAD2_" "_$$SID(%CIAIEN)
+7 QUIT
+8 ; Multi-term lookup
MTL NEW %
+1 SET %=$SELECT(%CIADIC[")":$TRANSLATE(%CIADIC,")",","),1:%CIADIC_"(")_"%CIAXRF)"
+2 SET %=$$LKP^CIAUMTL(%,%CIAD,"^TMP(""MTL"",%CIAPID)",%CIAOPT(0)[U)
+3 IF %<0
SET %CIATRNC=1
+4 IF %
DO ADD(%CIAPID,"^TMP","MTL")
+5 KILL ^TMP("MTL",%CIAPID)
+6 QUIT
+7 ; Add key to selection list
ADD(%CIAKEY,%CIAIDX,%CIASUB) ;
+1 NEW %S
+2 IF '$DATA(%CIAIDX)
SET %CIAIDX=%CIADIC
SET %CIASUB=%CIAXRF
+3 FOR %S=0:0
SET %S=$ORDER(@%CIAIDX@(%CIASUB,%CIAKEY,%S))
IF '%S
QUIT
Begin DoDot:1
+4 IF %CIAOPT(0)["O"
IF $DATA(^TMP(%CIAPID,0,%S))
QUIT
+5 IF $$VALD(%S)
Begin DoDot:2
+6 SET %CIASCT=%CIASCT+1
SET ^TMP(%CIAPID,%CIASCT)=%S_U_$SELECT(%CIAOPT(0)["W":"",1:%CIAKEY)
SET ^(0,%S)=""
+7 IF %CIAOPT(0)["S"
IF $GET(^DISV(DUZ,%CIADISV))=%S
SET %CIASLT=%CIASCT
End DoDot:2
End DoDot:1
+8 QUIT
+9 ; Check entry against screening criteria
VALD(%S) IF '$DATA(@%CIADIC@(%S))!'%S
QUIT 0
+1 IF %CIASCN=""
QUIT 1
+2 NEW %,%1
+3 SET %1=1
SET @$$TRAP^CIAUOS("V3^CIAULK2")
+4 FOR %=0:0
SET %=$ORDER(@%CIASCN@(%))
IF '%
QUIT
Begin DoDot:1
+5 SET %1=0
SET @$$TRAP^CIAUOS("V2^CIAULK2")
+6 XECUTE "S %1="_@%CIASCN@(%)
V2 QUIT
End DoDot:1
IF %1
QUIT
+1 QUIT %1
V3 QUIT 0
+1 ; Show the specified selection
SHOW(%CIASLCT,%CIACOL1,%CIACOL2) ;
+1 NEW %S,%Z,%P,%I
+2 SET %S=+%CIASLCT
SET %Z=$GET(@%CIADIC@(%S,0))
SET %P=$$FMT(%S,$SELECT(%CIAOPT["I":$PIECE(%CIASLCT,U,2),1:$PIECE(%Z,U)))
+3 ;S %I=$$SID(%S,$P(%CIASLCT,U,2)),%I=$S(%I="":%P,1:%I)
+4 SET %I=$$SID(%S,%P)
SET %I=$SELECT(%I="":%P,1:%I)
+5 IF %CIAHTML
Begin DoDot:1
+6 IF '%CIAQT
WRITE $$MSG^CIAU(%CIAPRMP,"|"),!
+7 IF '$TEST
DO DISV(%S)
End DoDot:1
QUIT
+8 SET %CIACOL1=+$GET(%CIACOL1,$X)
+9 IF %CIAOPT(0)["Y"
SET %CIACOL2=+$GET(%CIACOL2,IOM\%CIACOL+%CIACOL1-8-$LENGTH(%I))
+10 IF '$TEST
SET %CIACOL2=+$GET(%CIACOL2,IOM\%CIACOL\$SELECT(%CIAOPT(0)["D":3,1:2)-3+%CIACOL1)
+11 WRITE $$XY(%CIACOL1,$Y)
+12 IF %CIAOPT(0)'["J"
IF %I'=%P
WRITE $$TRUNC^CIAU(%P,IOM\%CIACOL-6),?%CIACOL2," "_$$TRUNC^CIAU(%I,IOM-%CIACOL2-2)
+13 IF '$TEST
WRITE $$TRUNC^CIAU(%I,IOM\%CIACOL-6)
+14 QUIT
+15 ; Return external form of result
FMT(%S,%CIAKEY) ;
+1 IF %CIAKEY=""
QUIT %CIAKEY
+2 IF %CIATRP'=""
IF $DATA(@%CIATRP@(%CIAKEY))
QUIT @%CIATRP@(%CIAKEY)
+3 IF %CIAOPT(0)["D"
SET %CIAKEY=$$ENTRY^CIAUDT(%CIAKEY)
+4 IF %CIAOPT(0)["Z"
IF %CIASCN'=""
IF $GET(@%CIASCN)'=""
SET @("%CIAKEY="_@%CIASCN)
+5 IF %CIAOPT["J"
SET %CIAKEY=$$SID(%S,%CIAKEY)
+6 QUIT %CIAKEY
+7 ; Return secondary identifier
SID(%S,%CIAKEY) ;
+1 SET %CIAKEY=$GET(%CIAKEY)
+2 NEW %Z
+3 SET %Z=$GET(@%CIADIC@(%S,0))
SET @("%Z="_$SELECT(%CIASID<0:$SELECT(%CIAKEY=$$UP^XLFSTR($PIECE(%Z,U)):"""""",1:"%CIAKEY"),%CIASID="":"%CIASID",1:%CIASID))
+4 QUIT %Z
+5 ; Partial key lookup
PARTIAL(%CIAD,%CIAKEY) ;
+1 NEW %,%1,%2
+2 SET (%(1),%(2))=0
SET %1(1)=%CIAD
SET %1(2)=%CIAKEY
+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 %CIAHLP'=""
DO @%CIAHLP
+3 WRITE !,"Enter a blank line for default action.",!
+4 IF $Y>20
DO PAUSE
+5 IF %CIAOPT'["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 (%CIAOPT'["*")&(%CIAXRFS[U)
WRITE " Append a * to include all indices."
+11 WRITE !
+12 IF %CIAOPT["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),%CIAEOS,!
+2 WRITE $SELECT(%CIAOPT(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 %CIAOPT(0)["M"
WRITE ?35,"Separate multiple selections by semicolons."
+7 READ !!,"Press any key to continue...",*%:DTIME
+8 QUIT
PAUSE IF %CIARS
QUIT
+1 NEW %
+2 READ !,"Press any key for more...",*%:DTIME
+3 WRITE $$XY(0,%CIAY+2),%CIAEOS
+4 QUIT
XY(X,Y) ;I %CIARS W:'X *13 S $X=X,$Y=Y Q ""
+1 IF %CIARS
SET Y=$Y
+2 QUIT $$XY^CIAU(X,Y)
