- 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)
