Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXQWA

LEXQWA.m

Go to the documentation of this file.
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