LEXQWS ;ISL/KER - Query - Words - Supplemental Keywords ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXSUP",$J) SACC 2.3.2.5.1
;
; External References
; ^DIC ICR 10006
; $$FMTE^XLFDT ICR 10103
;
EN ; Supplemental Keywords
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0 N LEXEXIT S LEXEXIT=0 W ! F D SUPL Q:+LEXEXIT>0
Q
SUPL ; Supplemental Keyword - Lookup
N LEXEFF,LEXEXS,LEXID,LEXIEN,LEXINA,LEXINS,LEXLEN,LEXTAB,LEXWRD
S LEXID="LEXSUP" K ^TMP(LEXID,$J),LEXA
S LEXLEN=$$KL,LEXTAB=3,LEXIEN=$$SUPA S:+LEXIEN'>0 LEXEXIT=1 Q:LEXEXIT>0
S LEXWRD=$P($G(^LEX(757.071,+LEXIEN,0)),"^",1) Q:'$L(LEXWRD)
S LEXEFF=$P($G(^LEX(757.071,+LEXIEN,0)),"^",2) Q:LEXEFF'?7N
S LEXINA=$P($G(^LEX(757.071,+LEXIEN,0)),"^",3)
S LEXINS=$P($G(^LEX(757.071,+LEXIEN,0)),"^",4) Q:'$L(LEXINS)
S LEXEXS=$P($G(^LEX(757.071,+LEXIEN,0)),"^",5)
S LEXT=" Keyword: "_LEXWRD
S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
S LEXT="",LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
S LEXT=" Effective: "_$$FMTE^XLFDT(LEXEFF,"5Z")
I LEXINA?7N D
. S LEXT=LEXT_$J(" ",(35-$L(LEXT)))_"Inactivated: "_$$FMTE^XLFDT(LEXINA,"5Z")
S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
S LEXT="",LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
S LEXT=" Used with expressions that:"
S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
S LEXT="",LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
F LEXI=1:1 Q:'$L($P(LEXINS,";",LEXI)) D
. N LEXT,LEXPH,LEXLDR S LEXPH=$P(LEXINS,";",LEXI),LEXLDR=" "
. S:LEXI=1 LEXLDR=" Include "
. S LEXT=LEXLDR_LEXPH
. S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
F LEXI=1:1 Q:'$L($P(LEXEXS,";",LEXI)) D
. N LEXT,LEXPH,LEXLDR S LEXPH=$P(LEXEXS,";",LEXI),LEXLDR=" "
. S:LEXI=1 LEXLDR=" Exclude "
. S LEXT=LEXLDR_LEXPH
. S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
D DSP^LEXQO(LEXID) W !
Q
SUPALL ; Supplemental Keyword - All
N LEXKEY,LEXKEYL,LEXINCL,LEXEXCL,LEXID S (LEXINCL,LEXEXCL)=0 S LEXKEYL=$$KL,LEXID="LEXSUP"
K ^TMP(LEXID,$J) S LEXKEY="" F S LEXKEY=$O(^LEX(757.071,"B",LEXKEY)) Q:'$L(LEXKEY) D
. N LEXT,LEXIEN,LEXICT,LEXECT,LEXIN,LEXEX
. S LEXT=LEXKEY
. S (LEXICT,LEXECT,LEXIEN)=0 F S LEXIEN=$O(^LEX(757.071,"B",LEXKEY,LEXIEN)) Q:+LEXIEN'>0 D
. . N LEXND,LEXEFF,LEXIAN,LEXINC,LEXINCP,LEXEXC,LEXEXCP,LEXPIE,LEXCT,LEXIN,LEXEX
. . S LEXND=$G(^LEX(757.071,+LEXIEN,0))
. . S LEXEFF=$P(LEXND,"^",2)
. . S LEXIAN=$P(LEXND,"^",3)
. . S LEXINC=$P(LEXND,"^",4) Q:'$L(LEXINC)
. . S LEXEXC=$P(LEXND,"^",5)
. . F LEXPIE=1:1 S LEXINCP=$P(LEXINC,";",LEXPIE) Q:'$L(LEXINCP) D
. . . N LEXI S LEXI=$O(LEXIN(" "),-1)+1,LEXIN(LEXI)=LEXINCP
. . F LEXPIE=1:1 S LEXEXCP=$P(LEXEXC,";",LEXPIE) Q:'$L(LEXEXCP) D
. . . N LEXI S LEXI=$O(LEXEX(" "),-1)+1,LEXEX(LEXI)=LEXEXCP
. . S LEXT=LEXKEY
. . S LEXT=LEXT_$J(" ",((LEXKEYL+2)-$L(LEXT)))_$G(LEXIN(1)) D IL(LEXT,LEXID)
. . S LEXPIE=1 F S LEXPIE=$O(LEXIN(LEXPIE)) Q:LEXPIE'>0 D
. . . N LEXD S LEXD=$G(LEXIN(LEXPIE)) Q:'$L(LEXD)
. . . S LEXT="",LEXT=LEXT_$J(" ",((LEXKEYL+2)-$L(LEXT)))_LEXD
. . . D IL(LEXT,LEXID)
. . I $L($G(LEXEX(1))) D
. . . S LEXT="",LEXT=LEXT_$J(" ",((LEXKEYL+2)-$L(LEXT)))_"Excludes:"
. . . S LEXT=LEXT_$J(" ",((LEXKEYL+13)-$L(LEXT)))_$G(LEXEX(1))
. . . D EL(LEXT,LEXID)
. . . S LEXPIE=1 F S LEXPIE=$O(LEXEX(LEXPIE)) Q:LEXPIE'>0 D
. . . . N LEXD,LEXS S LEXS=" ",LEXD=$G(LEXEX(LEXPIE)) Q:'$L(LEXD)
. . . . S LEXT="",LEXT=LEXT_$J(" ",((LEXKEYL+2)-$L(LEXT)))_LEXS_LEXD
. . . . D EL(LEXT,LEXID)
N CAP D DSP^LEXQO(LEXID)
Q
SUPA(X) ; Supplemental Keyword - Ask
N DIC,DTOUT,DUOUT,Y S DIC="^LEX(757.071,",DIC(0)="AEQM"
D ^DIC Q:$D(DTOUT)!($D(DUOUT)) "^" S X=+Y
Q X
ABROK(X) ; Supplemental Keyword - OK
N LEXI,LEXA,LEXO S LEXI=+($G(X)),LEXO=0,LEXA="" F S LEXA=$O(^LEX(757.07,"ABBR",LEXA)) Q:'$L(LEXA) D
. S:$D(^LEX(757.07,"ABBR",LEXA,+LEXI)) LEXO=1
S X=LEXO
Q X
;
; Miscellaneous
IL(X,Y) ; Include Text Line
N LEXT,LEXL,LEXI S LEXT=$G(X),LEXI=$G(Y) Q:'$L(LEXI) S LEXL=$O(^TMP(LEXI,$J," "),-1)+1
I $D(CAP) D Q
. I $E(LEXT,1)'=" " D
. . S LEXT=$$TM(LEXT),^TMP(LEXID,$J,LEXL)=($P(LEXT," ",1)_"~"_$$TM($P(LEXT," ",2,4000)))
. I $E(LEXT,1)=" " D
. . S LEXT=$$TM(LEXT),^TMP(LEXID,$J,LEXL)=$E(("~"_LEXT),1,79)
I '$D(CAP) D Q
. S ^TMP(LEXID,$J,LEXL)=$E((" "_LEXT),1,79)
Q
EL(X,Y) ; Exclude Text Line
N LEXT,LEXL,LEXI S LEXT=$G(X),LEXI=$G(Y) Q:'$L(LEXI) S LEXL=$O(^TMP(LEXI,$J," "),-1)+1
I $D(CAP) D Q
. I $E(LEXT,1)=" ",LEXT["Excludes:" D
. . S LEXT=$$TM(LEXT),^TMP(LEXID,$J,LEXL)=$E(("~"_$P(LEXT," ",1)_"~"_$$TM($P(LEXT," ",2,4000))),1,79)
. I $E(LEXT,1)=" ",LEXT'["Excludes:" D
. . S LEXT=$$TM(LEXT),^TMP(LEXID,$J,LEXL)=$E(("~~"_LEXT),1,79)
I '$D(CAP) D Q
. S ^TMP(LEXID,$J,LEXL)=$E((" "_LEXT),1,79)
Q
KL(X) ; Maximum Keyword Length
N LEX S X=0,LEX="" F S LEX=$O(^LEX(757.071,"B",LEX)) Q:'$L(LEX) S:$L(LEX)>X X=$L(LEX)
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQWS 5337 printed Nov 22, 2024@17:19:15 Page 2
LEXQWS ;ISL/KER - Query - Words - Supplemental Keywords ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXSUP",$J) SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; ^DIC ICR 10006
+8 ; $$FMTE^XLFDT ICR 10103
+9 ;
EN ; Supplemental Keywords
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
NEW LEXEXIT
SET LEXEXIT=0
WRITE !
FOR
DO SUPL
if +LEXEXIT>0
QUIT
+2 QUIT
SUPL ; Supplemental Keyword - Lookup
+1 NEW LEXEFF,LEXEXS,LEXID,LEXIEN,LEXINA,LEXINS,LEXLEN,LEXTAB,LEXWRD
+2 SET LEXID="LEXSUP"
KILL ^TMP(LEXID,$JOB),LEXA
+3 SET LEXLEN=$$KL
SET LEXTAB=3
SET LEXIEN=$$SUPA
if +LEXIEN'>0
SET LEXEXIT=1
if LEXEXIT>0
QUIT
+4 SET LEXWRD=$PIECE($GET(^LEX(757.071,+LEXIEN,0)),"^",1)
if '$LENGTH(LEXWRD)
QUIT
+5 SET LEXEFF=$PIECE($GET(^LEX(757.071,+LEXIEN,0)),"^",2)
if LEXEFF'?7N
QUIT
+6 SET LEXINA=$PIECE($GET(^LEX(757.071,+LEXIEN,0)),"^",3)
+7 SET LEXINS=$PIECE($GET(^LEX(757.071,+LEXIEN,0)),"^",4)
if '$LENGTH(LEXINS)
QUIT
+8 SET LEXEXS=$PIECE($GET(^LEX(757.071,+LEXIEN,0)),"^",5)
+9 SET LEXT=" Keyword: "_LEXWRD
+10 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+11 SET LEXT=""
SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+12 SET LEXT=" Effective: "_$$FMTE^XLFDT(LEXEFF,"5Z")
+13 IF LEXINA?7N
Begin DoDot:1
+14 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))_"Inactivated: "_$$FMTE^XLFDT(LEXINA,"5Z")
End DoDot:1
+15 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+16 SET LEXT=""
SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+17 SET LEXT=" Used with expressions that:"
+18 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+19 SET LEXT=""
SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+20 FOR LEXI=1:1
if '$LENGTH($PIECE(LEXINS,";",LEXI))
QUIT
Begin DoDot:1
+21 NEW LEXT,LEXPH,LEXLDR
SET LEXPH=$PIECE(LEXINS,";",LEXI)
SET LEXLDR=" "
+22 if LEXI=1
SET LEXLDR=" Include "
+23 SET LEXT=LEXLDR_LEXPH
+24 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
End DoDot:1
+25 FOR LEXI=1:1
if '$LENGTH($PIECE(LEXEXS,";",LEXI))
QUIT
Begin DoDot:1
+26 NEW LEXT,LEXPH,LEXLDR
SET LEXPH=$PIECE(LEXEXS,";",LEXI)
SET LEXLDR=" "
+27 if LEXI=1
SET LEXLDR=" Exclude "
+28 SET LEXT=LEXLDR_LEXPH
+29 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
End DoDot:1
+30 DO DSP^LEXQO(LEXID)
WRITE !
+31 QUIT
SUPALL ; Supplemental Keyword - All
+1 NEW LEXKEY,LEXKEYL,LEXINCL,LEXEXCL,LEXID
SET (LEXINCL,LEXEXCL)=0
SET LEXKEYL=$$KL
SET LEXID="LEXSUP"
+2 KILL ^TMP(LEXID,$JOB)
SET LEXKEY=""
FOR
SET LEXKEY=$ORDER(^LEX(757.071,"B",LEXKEY))
if '$LENGTH(LEXKEY)
QUIT
Begin DoDot:1
+3 NEW LEXT,LEXIEN,LEXICT,LEXECT,LEXIN,LEXEX
+4 SET LEXT=LEXKEY
+5 SET (LEXICT,LEXECT,LEXIEN)=0
FOR
SET LEXIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+6 NEW LEXND,LEXEFF,LEXIAN,LEXINC,LEXINCP,LEXEXC,LEXEXCP,LEXPIE,LEXCT,LEXIN,LEXEX
+7 SET LEXND=$GET(^LEX(757.071,+LEXIEN,0))
+8 SET LEXEFF=$PIECE(LEXND,"^",2)
+9 SET LEXIAN=$PIECE(LEXND,"^",3)
+10 SET LEXINC=$PIECE(LEXND,"^",4)
if '$LENGTH(LEXINC)
QUIT
+11 SET LEXEXC=$PIECE(LEXND,"^",5)
+12 FOR LEXPIE=1:1
SET LEXINCP=$PIECE(LEXINC,";",LEXPIE)
if '$LENGTH(LEXINCP)
QUIT
Begin DoDot:3
+13 NEW LEXI
SET LEXI=$ORDER(LEXIN(" "),-1)+1
SET LEXIN(LEXI)=LEXINCP
End DoDot:3
+14 FOR LEXPIE=1:1
SET LEXEXCP=$PIECE(LEXEXC,";",LEXPIE)
if '$LENGTH(LEXEXCP)
QUIT
Begin DoDot:3
+15 NEW LEXI
SET LEXI=$ORDER(LEXEX(" "),-1)+1
SET LEXEX(LEXI)=LEXEXCP
End DoDot:3
+16 SET LEXT=LEXKEY
+17 SET LEXT=LEXT_$JUSTIFY(" ",((LEXKEYL+2)-$LENGTH(LEXT)))_$GET(LEXIN(1))
DO IL(LEXT,LEXID)
+18 SET LEXPIE=1
FOR
SET LEXPIE=$ORDER(LEXIN(LEXPIE))
if LEXPIE'>0
QUIT
Begin DoDot:3
+19 NEW LEXD
SET LEXD=$GET(LEXIN(LEXPIE))
if '$LENGTH(LEXD)
QUIT
+20 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((LEXKEYL+2)-$LENGTH(LEXT)))_LEXD
+21 DO IL(LEXT,LEXID)
End DoDot:3
+22 IF $LENGTH($GET(LEXEX(1)))
Begin DoDot:3
+23 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((LEXKEYL+2)-$LENGTH(LEXT)))_"Excludes:"
+24 SET LEXT=LEXT_$JUSTIFY(" ",((LEXKEYL+13)-$LENGTH(LEXT)))_$GET(LEXEX(1))
+25 DO EL(LEXT,LEXID)
+26 SET LEXPIE=1
FOR
SET LEXPIE=$ORDER(LEXEX(LEXPIE))
if LEXPIE'>0
QUIT
Begin DoDot:4
+27 NEW LEXD,LEXS
SET LEXS=" "
SET LEXD=$GET(LEXEX(LEXPIE))
if '$LENGTH(LEXD)
QUIT
+28 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((LEXKEYL+2)-$LENGTH(LEXT)))_LEXS_LEXD
+29 DO EL(LEXT,LEXID)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 NEW CAP
DO DSP^LEXQO(LEXID)
+31 QUIT
SUPA(X) ; Supplemental Keyword - Ask
+1 NEW DIC,DTOUT,DUOUT,Y
SET DIC="^LEX(757.071,"
SET DIC(0)="AEQM"
+2 DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
SET X=+Y
+3 QUIT X
ABROK(X) ; Supplemental Keyword - OK
+1 NEW LEXI,LEXA,LEXO
SET LEXI=+($GET(X))
SET LEXO=0
SET LEXA=""
FOR
SET LEXA=$ORDER(^LEX(757.07,"ABBR",LEXA))
if '$LENGTH(LEXA)
QUIT
Begin DoDot:1
+2 if $DATA(^LEX(757.07,"ABBR",LEXA,+LEXI))
SET LEXO=1
End DoDot:1
+3 SET X=LEXO
+4 QUIT X
+5 ;
+6 ; Miscellaneous
IL(X,Y) ; Include Text Line
+1 NEW LEXT,LEXL,LEXI
SET LEXT=$GET(X)
SET LEXI=$GET(Y)
if '$LENGTH(LEXI)
QUIT
SET LEXL=$ORDER(^TMP(LEXI,$JOB," "),-1)+1
+2 IF $DATA(CAP)
Begin DoDot:1
+3 IF $EXTRACT(LEXT,1)'=" "
Begin DoDot:2
+4 SET LEXT=$$TM(LEXT)
SET ^TMP(LEXID,$JOB,LEXL)=($PIECE(LEXT," ",1)_"~"_$$TM($PIECE(LEXT," ",2,4000)))
End DoDot:2
+5 IF $EXTRACT(LEXT,1)=" "
Begin DoDot:2
+6 SET LEXT=$$TM(LEXT)
SET ^TMP(LEXID,$JOB,LEXL)=$EXTRACT(("~"_LEXT),1,79)
End DoDot:2
End DoDot:1
QUIT
+7 IF '$DATA(CAP)
Begin DoDot:1
+8 SET ^TMP(LEXID,$JOB,LEXL)=$EXTRACT((" "_LEXT),1,79)
End DoDot:1
QUIT
+9 QUIT
EL(X,Y) ; Exclude Text Line
+1 NEW LEXT,LEXL,LEXI
SET LEXT=$GET(X)
SET LEXI=$GET(Y)
if '$LENGTH(LEXI)
QUIT
SET LEXL=$ORDER(^TMP(LEXI,$JOB," "),-1)+1
+2 IF $DATA(CAP)
Begin DoDot:1
+3 IF $EXTRACT(LEXT,1)=" "
IF LEXT["Excludes:"
Begin DoDot:2
+4 SET LEXT=$$TM(LEXT)
SET ^TMP(LEXID,$JOB,LEXL)=$EXTRACT(("~"_$PIECE(LEXT," ",1)_"~"_$$TM($PIECE(LEXT," ",2,4000))),1,79)
End DoDot:2
+5 IF $EXTRACT(LEXT,1)=" "
IF LEXT'["Excludes:"
Begin DoDot:2
+6 SET LEXT=$$TM(LEXT)
SET ^TMP(LEXID,$JOB,LEXL)=$EXTRACT(("~~"_LEXT),1,79)
End DoDot:2
End DoDot:1
QUIT
+7 IF '$DATA(CAP)
Begin DoDot:1
+8 SET ^TMP(LEXID,$JOB,LEXL)=$EXTRACT((" "_LEXT),1,79)
End DoDot:1
QUIT
+9 QUIT
KL(X) ; Maximum Keyword Length
+1 NEW LEX
SET X=0
SET LEX=""
FOR
SET LEX=$ORDER(^LEX(757.071,"B",LEX))
if '$LENGTH(LEX)
QUIT
if $LENGTH(LEX)>X
SET X=$LENGTH(LEX)
+2 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
