XTLKDICL.m

XTLKDICL ; IHS/ACC,ALB/JLU,SFISC/JC ;10/11/94  14:42 [ 04/02/2003   8:47 AM ]

 ;;7.3;TOOLKIT;**1001**;APR 1, 2003

 ;;7.3;TOOLKIT;;Apr 25, 1995

 ;THIS ROUTINE CONTAINS IHS MODIFICATIONS BY IHS/CMI/LAB 1/24/2001

 ;AND IHS/ANMC/FBD 11/20/96

 ;Bypass special lookup if XTLKUT exists or DIC(0)["I"

 I $D(XTLKUT) S:DIC(0)'["I" DIC(0)=DIC(0)_"I" G:$G(DIPGM(0))=2 RTN^DIC D ^DIC Q

 S:'$D(X) X=""

 I X?1"?".E S X="~"_X

 G:DIPGM(0)=2 EN2

EN1 ; FIRST ENTRY FROM DIC

 K HITLIMIT

 ;----- BEGIN IHS MODIFICATION

 ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 ;ORIGINAL MODIFICATION BY IHS/CMI/LAB 1/24/2001

 ;G:DIC(0)["A" ASK^DIC

 I DIC(0)["A" K DO D DO^DIC1 G ASK^DIC

 ;----- END IHS MODIFICATION

EN2 ; SECOND ENTRY FROM DIC OR FALL-THROUGH IF NO 'ASK' INDICATED

 I X="?BAD"!(X["^") S Y=-1 Q

 ;Precede entry with "`" to 'force' lookup by IEN

 ;----- BEGIN IHS MODIFICATION

 ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 ;ORIGINAL MODIFICATION BY IHS/CMI/LAB 1/24/2001

 ;I X?1"`"1N.N!(U[X)!(X?1N.N)!(X?.N1".".N) D:'$D(D0(2)) DO^DIC1 G RTN^DIC

 I X?1"`"1N.N!(U[X)!(X?1N.N)!(X?.N1".".N) K DO D DO^DIC1 G RTN^DIC

 ;----- END IHS MODIFICATION

 ;Precede entry with "~" to 'force' lookup by ALL X-REF'S

 I X?1"~".E S X=$E(X,2,99) D:'$D(D0(2)) DO^DIC1 G RTN^DIC

 ;Setting up var, from old xtlkkwld routine

TS D DO^DIC1 I $D(DO(2)),'$D(^XT(8984.4,+DO(2),0)) W $C(7),!!,"'",$P(DO,U),"' is not in the 'Local Lookup Files' file. Unable to use lookup." S Y=-1 Q

 S XTLKX=X K XTLKKSCH S XTLKKSCH("GBL")=DIC,XTLKKSCH("INDEX")=$P(^XT(8984.4,+DO(2),0),U,3)

 S XTLKKSCH("DSPLY")=$S('$D(^XT(8984.4,+DO(2),1)):"DGEN^XTLKKWLD",$L(^(1))=0:"DGEN^XTLKKWLD",1:^(1))

 I $D(DIC(0)),DIC(0)["A" W !

 S X=XTLKX,XTLKX="" F XTLKPC=1:1 S XTLKC=$E(X,XTLKPC) Q:XTLKC=""  S:XTLKC?1L XTLKC=$C($A(XTLKC)-32) S XTLKX=XTLKX_XTLKC

 K XTLKC

 D ^XTLKKWL

 Q:$D(DIROUT)!($D(DTOUT))

 ;----- BEGIN IHS MODIFICATION

 ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE TO ADD XTLKSAY

 ;(VERBOSE/SILENT) FLAG CHECK TO WRITE STATEMENT

 ;ORIGINAL MODIFICATION BY IHS/ANMC/FBD 11/20/96

 ;I +Y=-1 S X="~"_X W !,"Attempting FILEMAN lookup..." G EN2

 I +Y=-1 S X="~"_X W:XTLKSAY=1 !,"Attempting FILEMAN lookup..." G EN2

 ;----- END IHS MODIFICATION

 Q

XTLKDICL  ; IHS/ACC,ALB/JLU,SFISC/JC ;10/11/94  14:42 [ 04/02/2003   8:47 AM ]

 +1       ;;7.3;TOOLKIT;**1001**;APR 1, 2003

 +2       ;;7.3;TOOLKIT;;Apr 25, 1995

 +3       ;THIS ROUTINE CONTAINS IHS MODIFICATIONS BY IHS/CMI/LAB 1/24/2001

 +4       ;AND IHS/ANMC/FBD 11/20/96

 +5       ;Bypass special lookup if XTLKUT exists or DIC(0)["I"

 +6        IF $DATA(XTLKUT)

               IF DIC(0)'["I"

                   SET DIC(0)=DIC(0)_"I"

               IF $GET(DIPGM(0))=2

                   GOTO RTN^DIC

               DO ^DIC

               QUIT 

 +7        IF '$DATA(X)

               SET X=""

 +8        IF X?1"?".E

               SET X="~"_X

 +9        IF DIPGM(0)=2

               GOTO EN2

EN1       ; FIRST ENTRY FROM DIC

 +1        KILL HITLIMIT

 +2       ;----- BEGIN IHS MODIFICATION

 +3       ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 +4       ;ORIGINAL MODIFICATION BY IHS/CMI/LAB 1/24/2001

 +5       ;G:DIC(0)["A" ASK^DIC

 +6        IF DIC(0)["A"

               KILL DO

               DO DO^DIC1

               GOTO ASK^DIC

 +7       ;----- END IHS MODIFICATION

EN2       ; SECOND ENTRY FROM DIC OR FALL-THROUGH IF NO 'ASK' INDICATED

 +1        IF X="?BAD"!(X["^")

               SET Y=-1

               QUIT 

 +2       ;Precede entry with "`" to 'force' lookup by IEN

 +3       ;----- BEGIN IHS MODIFICATION

 +4       ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 +5       ;ORIGINAL MODIFICATION BY IHS/CMI/LAB 1/24/2001

 +6       ;I X?1"`"1N.N!(U[X)!(X?1N.N)!(X?.N1".".N) D:'$D(D0(2)) DO^DIC1 G RTN^DIC

 +7        IF X?1"`"1N.N!(U[X)!(X?1N.N)!(X?.N1".".N)

               KILL DO

               DO DO^DIC1

               GOTO RTN^DIC

 +8       ;----- END IHS MODIFICATION

 +9       ;Precede entry with "~" to 'force' lookup by ALL X-REF'S

 +10       IF X?1"~".E

               SET X=$EXTRACT(X,2,99)

               IF '$DATA(D0(2))

                   DO DO^DIC1

               GOTO RTN^DIC

 +11      ;Setting up var, from old xtlkkwld routine

TS         DO DO^DIC1

           IF $DATA(DO(2))

               IF '$DATA(^XT(8984.4,+DO(2),0))

                   WRITE $CHAR(7),!!,"'",$PIECE(DO,U),"' is not in the 'Local Lookup Files' file. Unable to use lookup."

                   SET Y=-1

                   QUIT 

 +1        SET XTLKX=X

           KILL XTLKKSCH

           SET XTLKKSCH("GBL")=DIC

           SET XTLKKSCH("INDEX")=$PIECE(^XT(8984.4,+DO(2),0),U,3)

 +2        SET XTLKKSCH("DSPLY")=$SELECT('$DATA(^XT(8984.4,+DO(2),1)):"DGEN^XTLKKWLD",$LENGTH(^(1))=0:"DGEN^XTLKKWLD",1:^(1))

 +3        IF $DATA(DIC(0))

               IF DIC(0)["A"

                   WRITE !

 +4        SET X=XTLKX

           SET XTLKX=""

           FOR XTLKPC=1:1

               SET XTLKC=$EXTRACT(X,XTLKPC)

               IF XTLKC=""

                   QUIT 

               IF XTLKC?1L

                   SET XTLKC=$CHAR($ASCII(XTLKC)-32)

               SET XTLKX=XTLKX_XTLKC

 +5        KILL XTLKC

 +6        DO ^XTLKKWL

 +7        IF $DATA(DIROUT)!($DATA(DTOUT))

               QUIT 

 +8       ;----- BEGIN IHS MODIFICATION

 +9       ;LINE IS COMMENTED OUT AND REPLACED BY NEW LINE TO ADD XTLKSAY

 +10      ;(VERBOSE/SILENT) FLAG CHECK TO WRITE STATEMENT

 +11      ;ORIGINAL MODIFICATION BY IHS/ANMC/FBD 11/20/96

 +12      ;I +Y=-1 S X="~"_X W !,"Attempting FILEMAN lookup..." G EN2

 +13       IF +Y=-1

               SET X="~"_X

               IF XTLKSAY=1

                   WRITE !,"Attempting FILEMAN lookup..."

               GOTO EN2

 +14      ;----- END IHS MODIFICATION

 +15       QUIT