CIAULKP.m

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