- 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 Mar 13, 2025@21:13:37 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
