LEXQWA ;ISL/KER - Query - Words - Abbreviations ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXABR",$J) SACC 2.3.2.5.1
;
; External References
; ^DIC ICR 10006
;
EN ; Abbreviations
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0 N LEXEXIT S LEXEXIT=0 W ! F D ABRL Q:+LEXEXIT>0
Q
ABRL ; Abbreviation - Lookup
N LEXIEN,LEXABR,LEXOIEN,LEXA,LEXEXM,LEXID,LEXLEN,LEXTAB,LEXUNQ S LEXID="LEXABR" K ^TMP(LEXID,$J),LEXA
S LEXLEN=$$AL S (LEXTAB,LEXLEN)=$S(+LEXLEN>0:(LEXLEN+2),1:15) S LEXLEN=(74-LEXLEN),LEXTAB=LEXTAB+1
S LEXIEN=$$ABRA S:+LEXIEN'>0 LEXEXIT=1 Q:LEXEXIT>0
S LEXABR=$P($G(^LEX(757.07,+LEXIEN,0)),"^",1) S:'$L(LEXABR) LEXEXIT=1 Q:LEXEXIT>0
S LEXOIEN=0 F S LEXOIEN=$O(^LEX(757.07,+LEXIEN,1,LEXOIEN)) Q:+LEXOIEN'>0 D
. Q:$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",5)'>0
. N LEXEXM,LEXFUL,LEXP
. S LEXEXM=$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",3) Q:'$L(LEXEXM)
. S LEXFUL=$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",4) Q:'$L(LEXFUL)
. Q:$D(LEXUNQ(LEXFUL)) S LEXUNQ(LEXFUL)=""
. F LEXP=1:1 Q:'$L($P(LEXFUL,"/",LEXP)) D
. . N LEXI,LEXO,LEXT S LEXT(1)=$P(LEXFUL,"/",LEXP) D PR^LEXU(.LEXT,LEXLEN)
. . S LEXI=1 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEXT(LEXI)=" "_$G(LEXT(LEXI))
. . S LEXO=0 F S LEXO=$O(LEXT(LEXO)) Q:+LEXO'>0 D
. . . N LEXS S LEXS=$G(LEXT(LEXO)) Q:'$L(LEXO)
. . . S LEXI=$O(LEXA(LEXEXM," "),-1)+1,LEXA(LEXEXM,LEXI)=$G(LEXT(LEXO))
I '$D(LEXA) W !,"No definition found for abbreviation ",LEXABR,!
S LEXEXM="" F S LEXEXM=$O(LEXA(LEXEXM)) Q:'$L(LEXEXM) D
. N LEXT,LEXI,LEXO S LEXT=" "_LEXEXM S LEXT=LEXT_$J(" ",(LEXTAB-$L(LEXT)))_$G(LEXA(LEXEXM,1))
. S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
. S LEXI=1 F S LEXI=$O(LEXA(LEXEXM,LEXI)) Q:+LEXI'>0 D
. . N LEXT,LEXO S LEXT="" S LEXT=LEXT_$J(" ",(LEXTAB-$L(LEXT)))_$G(LEXA(LEXEXM,LEXI))
. . S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
D DSP^LEXQO(LEXID) W !
Q
ABRALL ; Abbreviation - All
N LEXABR,LEXLEN,LEXEXM,LEXTAB,LEXID,I,Z S LEXID="LEXABR" K ^TMP(LEXID,$J) S LEXLEN=$$AL
S (LEXTAB,LEXLEN)=$S(+LEXLEN>0:(LEXLEN+2),1:15) S LEXLEN=(74-LEXLEN),LEXTAB=LEXTAB+1
S LEXABR="" F S LEXABR=$O(^LEX(757.07,"ABBR",LEXABR)) Q:'$L(LEXABR) D
. N LEXIEN,LEXA K LEXA S LEXIEN=0 F S LEXIEN=$O(^LEX(757.07,"ABBR",LEXABR,LEXIEN)) Q:+LEXIEN'>0 D
. . N LEXOIEN,LEXUNQ S LEXOIEN=0 F S LEXOIEN=$O(^LEX(757.07,+LEXIEN,1,LEXOIEN)) Q:+LEXOIEN'>0 D
. . . Q:$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",5)'>0
. . . N LEXEXM,LEXFUL,LEXP,LEXTKNS
. . . S LEXEXM=$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",3) Q:'$L(LEXEXM)
. . . S LEXFUL=$P($G(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",4) Q:'$L(LEXFUL)
. . . Q:$D(LEXUNQ(LEXFUL)) S LEXUNQ(LEXFUL)=""
. . . F LEXP=1:1 Q:'$L($P(LEXFUL,"/",LEXP)) D
. . . . N LEXTK S LEXTK=$P(LEXFUL,"/",LEXP) Q:'$L(LEXTK)
. . . . Q:$D(LEXTKNS(LEXTK)) S LEXTKNS(LEXTK)=""
. . . . S:$D(CAP) LEXLEN=2000 N LEXI,LEXO,LEXT S LEXT(1)=LEXTK D:'$D(CAP) PR^LEXU(.LEXT,LEXLEN)
. . . . S LEXI=1 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEXT(LEXI)=" "_$G(LEXT(LEXI))
. . . . S LEXO=0 F S LEXO=$O(LEXT(LEXO)) Q:+LEXO'>0 D
. . . . . N LEXS S LEXS=$G(LEXT(LEXO)) Q:'$L(LEXO)
. . . . . S LEXI=$O(LEXA(LEXEXM," "),-1)+1,LEXA(LEXEXM,LEXI)=$G(LEXT(LEXO))
. . Q:'$D(LEXA)
. . S LEXEXM="" F S LEXEXM=$O(LEXA(LEXEXM)) Q:'$L(LEXEXM) D
. . . N LEXT,LEXI,LEXO S LEXT=" "_LEXEXM S LEXT=LEXT_$J(" ",(LEXTAB-$L(LEXT)))_$G(LEXA(LEXEXM,1))
. . . S:$D(CAP) LEXT=$$TM(LEXT) S:$D(CAP) LEXT=$P(LEXT," ",1)_"~"_$$TM($P(LEXT," ",2,4000))
. . . S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
. . . S LEXI=1 F S LEXI=$O(LEXA(LEXEXM,LEXI)) Q:+LEXI'>0 D
. . . . N LEXT,LEXO S LEXT="" S LEXT=LEXT_$J(" ",(LEXTAB-$L(LEXT)))_$G(LEXA(LEXEXM,LEXI))
. . . . S:$D(CAP) LEXT=$$TM(LEXT) S:$D(CAP) LEXT="~"_LEXT
. . . . S LEXO=$O(^TMP(LEXID,$J," "),-1)+1 S ^TMP(LEXID,$J,LEXO)=LEXT
D DSP^LEXQO(LEXID) W ! N CAP
Q
ABRA(X) ; Abbreviation - Ask
N DIC,DTOUT,DUOUT,Y S DIC="^LEX(757.07,",DIC(0)="AEQM",DIC("S")="I $$ABROK^LEXQWA(+Y)",DIC("A")=" Enter an Abbreviation: "
D ^DIC Q:$D(DTOUT)!($D(DUOUT)) "^" S X=+Y
Q X
ABROK(X) ; Abbreviation - 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
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
AL(X) ; Maximum Abbreviation Length
N LEXM,LEXA S LEXM=0,LEXA="" F S LEXA=$O(^LEX(757.07,"ABBR",LEXA)) Q:'$L(LEXA) S:$L(LEXA)>LEXM LEXM=$L(LEXA)
S X=LEXM
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQWA 4875 printed Sep 23, 2025@19:45 Page 2
LEXQWA ;ISL/KER - Query - Words - Abbreviations ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXABR",$J) SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; ^DIC ICR 10006
+8 ;
EN ; Abbreviations
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
NEW LEXEXIT
SET LEXEXIT=0
WRITE !
FOR
DO ABRL
if +LEXEXIT>0
QUIT
+2 QUIT
ABRL ; Abbreviation - Lookup
+1 NEW LEXIEN,LEXABR,LEXOIEN,LEXA,LEXEXM,LEXID,LEXLEN,LEXTAB,LEXUNQ
SET LEXID="LEXABR"
KILL ^TMP(LEXID,$JOB),LEXA
+2 SET LEXLEN=$$AL
SET (LEXTAB,LEXLEN)=$SELECT(+LEXLEN>0:(LEXLEN+2),1:15)
SET LEXLEN=(74-LEXLEN)
SET LEXTAB=LEXTAB+1
+3 SET LEXIEN=$$ABRA
if +LEXIEN'>0
SET LEXEXIT=1
if LEXEXIT>0
QUIT
+4 SET LEXABR=$PIECE($GET(^LEX(757.07,+LEXIEN,0)),"^",1)
if '$LENGTH(LEXABR)
SET LEXEXIT=1
if LEXEXIT>0
QUIT
+5 SET LEXOIEN=0
FOR
SET LEXOIEN=$ORDER(^LEX(757.07,+LEXIEN,1,LEXOIEN))
if +LEXOIEN'>0
QUIT
Begin DoDot:1
+6 if $PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",5)'>0
QUIT
+7 NEW LEXEXM,LEXFUL,LEXP
+8 SET LEXEXM=$PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",3)
if '$LENGTH(LEXEXM)
QUIT
+9 SET LEXFUL=$PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",4)
if '$LENGTH(LEXFUL)
QUIT
+10 if $DATA(LEXUNQ(LEXFUL))
QUIT
SET LEXUNQ(LEXFUL)=""
+11 FOR LEXP=1:1
if '$LENGTH($PIECE(LEXFUL,"/",LEXP))
QUIT
Begin DoDot:2
+12 NEW LEXI,LEXO,LEXT
SET LEXT(1)=$PIECE(LEXFUL,"/",LEXP)
DO PR^LEXU(.LEXT,LEXLEN)
+13 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEXT(LEXI)=" "_$GET(LEXT(LEXI))
+14 SET LEXO=0
FOR
SET LEXO=$ORDER(LEXT(LEXO))
if +LEXO'>0
QUIT
Begin DoDot:3
+15 NEW LEXS
SET LEXS=$GET(LEXT(LEXO))
if '$LENGTH(LEXO)
QUIT
+16 SET LEXI=$ORDER(LEXA(LEXEXM," "),-1)+1
SET LEXA(LEXEXM,LEXI)=$GET(LEXT(LEXO))
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF '$DATA(LEXA)
WRITE !,"No definition found for abbreviation ",LEXABR,!
+18 SET LEXEXM=""
FOR
SET LEXEXM=$ORDER(LEXA(LEXEXM))
if '$LENGTH(LEXEXM)
QUIT
Begin DoDot:1
+19 NEW LEXT,LEXI,LEXO
SET LEXT=" "_LEXEXM
SET LEXT=LEXT_$JUSTIFY(" ",(LEXTAB-$LENGTH(LEXT)))_$GET(LEXA(LEXEXM,1))
+20 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+21 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXEXM,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+22 NEW LEXT,LEXO
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXTAB-$LENGTH(LEXT)))_$GET(LEXA(LEXEXM,LEXI))
+23 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
End DoDot:2
End DoDot:1
+24 DO DSP^LEXQO(LEXID)
WRITE !
+25 QUIT
ABRALL ; Abbreviation - All
+1 NEW LEXABR,LEXLEN,LEXEXM,LEXTAB,LEXID,I,Z
SET LEXID="LEXABR"
KILL ^TMP(LEXID,$JOB)
SET LEXLEN=$$AL
+2 SET (LEXTAB,LEXLEN)=$SELECT(+LEXLEN>0:(LEXLEN+2),1:15)
SET LEXLEN=(74-LEXLEN)
SET LEXTAB=LEXTAB+1
+3 SET LEXABR=""
FOR
SET LEXABR=$ORDER(^LEX(757.07,"ABBR",LEXABR))
if '$LENGTH(LEXABR)
QUIT
Begin DoDot:1
+4 NEW LEXIEN,LEXA
KILL LEXA
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.07,"ABBR",LEXABR,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+5 NEW LEXOIEN,LEXUNQ
SET LEXOIEN=0
FOR
SET LEXOIEN=$ORDER(^LEX(757.07,+LEXIEN,1,LEXOIEN))
if +LEXOIEN'>0
QUIT
Begin DoDot:3
+6 if $PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",5)'>0
QUIT
+7 NEW LEXEXM,LEXFUL,LEXP,LEXTKNS
+8 SET LEXEXM=$PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",3)
if '$LENGTH(LEXEXM)
QUIT
+9 SET LEXFUL=$PIECE($GET(^LEX(757.07,+LEXIEN,1,+LEXOIEN,0)),"^",4)
if '$LENGTH(LEXFUL)
QUIT
+10 if $DATA(LEXUNQ(LEXFUL))
QUIT
SET LEXUNQ(LEXFUL)=""
+11 FOR LEXP=1:1
if '$LENGTH($PIECE(LEXFUL,"/",LEXP))
QUIT
Begin DoDot:4
+12 NEW LEXTK
SET LEXTK=$PIECE(LEXFUL,"/",LEXP)
if '$LENGTH(LEXTK)
QUIT
+13 if $DATA(LEXTKNS(LEXTK))
QUIT
SET LEXTKNS(LEXTK)=""
+14 if $DATA(CAP)
SET LEXLEN=2000
NEW LEXI,LEXO,LEXT
SET LEXT(1)=LEXTK
if '$DATA(CAP)
DO PR^LEXU(.LEXT,LEXLEN)
+15 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEXT(LEXI)=" "_$GET(LEXT(LEXI))
+16 SET LEXO=0
FOR
SET LEXO=$ORDER(LEXT(LEXO))
if +LEXO'>0
QUIT
Begin DoDot:5
+17 NEW LEXS
SET LEXS=$GET(LEXT(LEXO))
if '$LENGTH(LEXO)
QUIT
+18 SET LEXI=$ORDER(LEXA(LEXEXM," "),-1)+1
SET LEXA(LEXEXM,LEXI)=$GET(LEXT(LEXO))
End DoDot:5
End DoDot:4
End DoDot:3
+19 if '$DATA(LEXA)
QUIT
+20 SET LEXEXM=""
FOR
SET LEXEXM=$ORDER(LEXA(LEXEXM))
if '$LENGTH(LEXEXM)
QUIT
Begin DoDot:3
+21 NEW LEXT,LEXI,LEXO
SET LEXT=" "_LEXEXM
SET LEXT=LEXT_$JUSTIFY(" ",(LEXTAB-$LENGTH(LEXT)))_$GET(LEXA(LEXEXM,1))
+22 if $DATA(CAP)
SET LEXT=$$TM(LEXT)
if $DATA(CAP)
SET LEXT=$PIECE(LEXT," ",1)_"~"_$$TM($PIECE(LEXT," ",2,4000))
+23 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
+24 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXEXM,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:4
+25 NEW LEXT,LEXO
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(LEXTAB-$LENGTH(LEXT)))_$GET(LEXA(LEXEXM,LEXI))
+26 if $DATA(CAP)
SET LEXT=$$TM(LEXT)
if $DATA(CAP)
SET LEXT="~"_LEXT
+27 SET LEXO=$ORDER(^TMP(LEXID,$JOB," "),-1)+1
SET ^TMP(LEXID,$JOB,LEXO)=LEXT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 DO DSP^LEXQO(LEXID)
WRITE !
NEW CAP
+29 QUIT
ABRA(X) ; Abbreviation - Ask
+1 NEW DIC,DTOUT,DUOUT,Y
SET DIC="^LEX(757.07,"
SET DIC(0)="AEQM"
SET DIC("S")="I $$ABROK^LEXQWA(+Y)"
SET DIC("A")=" Enter an Abbreviation: "
+2 DO ^DIC
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
SET X=+Y
+3 QUIT X
ABROK(X) ; Abbreviation - 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
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
AL(X) ; Maximum Abbreviation Length
+1 NEW LEXM,LEXA
SET LEXM=0
SET LEXA=""
FOR
SET LEXA=$ORDER(^LEX(757.07,"ABBR",LEXA))
if '$LENGTH(LEXA)
QUIT
if $LENGTH(LEXA)>LEXM
SET LEXM=$LENGTH(LEXA)
+2 SET X=LEXM
+3 QUIT X
