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

LEX10CX5.m

Go to the documentation of this file.
LEX10CX5 ;ISL/KER - ICD-10 Cross-Over - Misc ;04/21/2014
 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
 ;               
 ; Global Variables
 ;    None
 ;               
 ; External References
 ;    $$DT^XLFDT          ICR  10103
 ;    $$UP^XLFSTR         ICR  10104
 ;               
 ; Local Variables NEWed or KILLed Elsewhere
 ;    None
 ;               
 ; Parse Expression into Segments
SEG(X,LEXS) ;   Get Segment Array
 N LEXA,LEXI,LEXSG,LEXSI,LEXT S LEXT=$G(X)
 S:'$L(LEXT) LEXT=$G(LEXS("SOURCE","EXP"))
 Q:'$L(LEXT)  D SEGS(LEXT,1,.LEXA) S LEXI=0
 F  S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0  D
 . N LEXSG,LEXSI S LEXSG=$G(LEXA(LEXI)) Q:'$L(LEXSG)
 . S LEXSI=$O(LEXS("SEG"," "),-1)+1
 . S LEXS("SEG",LEXSI)=LEXSG
 Q
SEGS(X,Y,LEXA) ;     Parse Text into Segments
 N LEXBEG,LEXC,LEXCHR,LEXEND,LEXFRE,LEXI,LEXNUM,LEXORD,LEXSEG
 N LEXTMP,LEXTXT,LEXVAL,LEXFLG S LEXTXT=$$UP^XLFSTR(X)
 S LEXFLG=$G(Y) K LEXA,LEXTMP
 S LEXBEG=1 F LEXEND=1:1:$L(LEXTXT)+1 D
 . S LEXCHR=$E(LEXTXT,LEXEND)
 . I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXCHR D
 . . S LEXSEG=$E(LEXTXT,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1
 . . I $L(LEXSEG)>1,$L(LEXSEG)<31,$$EXC(LEXSEG) D
 . . . N LEXI,LEXNUM S LEXNUM=(246-$L(LEXSEG))
 . . . S LEXI=$O(LEXTMP(" "),-1)+1,LEXTMP(LEXI)=LEXSEG
 I +($G(LEXFLG))'>0 S LEXI="" D
 . F  S LEXI=$O(LEXTMP(LEXI)) Q:'$L(LEXI)  D
 . . S LEXA(LEXI)=LEXTMP(LEXI)
 I +($G(LEXFLG))>0 D
 . N LEXORD,LEXI,LEXC K LEXORD
 . S LEXI="" F  S LEXI=$O(LEXTMP(LEXI)) Q:'$L(LEXI)  D
 . . N LEXFRE,LEXVAL S LEXVAL=$G(LEXTMP(LEXI))
 . . I LEXVAL="0" S LEXORD(0)=LEXVAL Q
 . . S LEXFRE=$$FREQ^LEXU(LEXVAL) Q:+LEXFRE'>0
 . . S LEXORD(LEXFRE)=LEXVAL
 . S LEXI="" F  S LEXI=$O(LEXORD(LEXI)) Q:'$L(LEXI)  D
 . . S LEXVAL=$G(LEXORD(LEXI))
 . . I LEXI="0" S LEXA(LEXI)=LEXVAL Q
 . . S LEXC=$O(LEXA(" "),-1)+1,LEXA(LEXC)=LEXVAL
 Q
EXC(X) ;     Exclude from Lookup
 Q:$L($G(X))'>1 0
 Q:"^AS^ABOUT^AFTER^ALMOST^ALSO^ALTHOUGH^AND^"[("^"_$G(X)_"^") 0
 Q:"^ANOTHER^ANY^ARE^AREA^AREAS^AT^BE^BEEN^"[("^"_$G(X)_"^") 0
 Q:"^BEFORE^BEST^BUT^BY^CAN^CONTROLLED^COULD^"[("^"_$G(X)_"^") 0
 Q:"^COMPLICATINS^DONE^DUE^EACH^EVEN^FAR^FOR^FORM^"[("^"_$G(X)_"^") 0
 Q:"^FORMS^FORTH^FROM^GIVEN^HAD^^"[("^"_$G(X)_"^") 0
 Q:"^HAVE^HER^HERE^HERSELF^HIM^"[("^"_$G(X)_"^") 0
 Q:"^HIMSELF^HIS^HOW^IN^INTO^IS^IT^IT'S^ITS^^"[("^"_$G(X)_"^") 0
 Q:"^ITS'^ITSELF^KIND^LIKE^LOST^MANY^MAY^MERE^"[("^"_$G(X)_"^") 0
 Q:"^MORE^MOST^MUST^NEW^NOT^NOTE^NOW^OF^OFTEN^"[("^"_$G(X)_"^") 0
 Q:"^ON^ONESELF^ONLY^OR^OUR^OURS^OUT^OTHER^OWN^PUT^"[("^"_$G(X)_"^") 0
 Q:"^SAME^SET^SHOULD^SOME^STATED^SUCH^SURE^"[("^"_$G(X)_"^") 0
 Q:"^THAN^THAT^THE^THEN^THERE^THEREBY^THESE^"[("^"_$G(X)_"^") 0
 Q:"^THEY^THIS^THUS^TO^TOO^UPON^UNSPECIFIED^"[("^"_$G(X)_"^") 0
 Q:"^UNCONTROLLED^W/^W/O^WAS^WHAT^WHEN^WHERE^"[("^"_$G(X)_"^") 0
 Q:"^WHICH^WHO^WHOSE^WITH^WITHIN^WITHOUT^WO^"[("^"_$G(X)_"^") 0
 Q:"^WOULD^"[("^"_$G(X)_"^") 0
 Q 1
  ;
  ; Miscellaneous
RN(X,Y) ;   Common Roman Numerals
 N LEX1,LEX2,LEXI,LEXK,LEXP,LEXS,LEXS2,LEXSG,LEXSGI,LEXX,LEXCT,LEXTX
 S LEXSG=$G(X),LEXX=$G(Y)
 S LEXS="I;1^II;2^III;3^IV;4^V;5^VI;6^VII;7"
 S LEXS=LEXS_"^VIII;8^IX;9^X;10^XI;11^XII;12"
 S LEXS2=("^"_$TR(LEXS,";","^")_"^")
 Q:LEXS2'[("^"_LEXSG_"^") 0
 S LEXK=0 F LEXP=1:1 Q:'$L($P(LEXS,"^",LEXP))  D  Q:LEXK
 . S LEX1=$P($P(LEXS,"^",LEXP),";",1),LEX2=$P($P(LEXS,"^",LEXP),";",2)
 . I $E(LEXX,1,($L(LEX1)+1))=(LEX1_" ") S LEXK=1 Q
 . I $E(LEXX,1,($L(LEX2)+1))=(LEX2_" ") S LEXK=1 Q
 . I (LEXX[(" "_LEX1_" ")!(LEXX[(" "_LEX1_","))) S LEXK=1 Q
 . I (LEXX[(" "_LEX2_" ")!(LEXX[(" "_LEX2_","))) S LEXK=1 Q
 . I $E(LEXX,($L(LEXX)-($L(LEX1))),($L(LEXX)+1))=(" "_LEX1) S LEXK=1 Q
 . I $E(LEXX,($L(LEXX)-($L(LEX2))),($L(LEXX)+1))=(" "_LEX2) S LEXK=1 Q
 Q LEXK
TY(X,Y) ;   Common Types
 Q 0
 N LEXOR,LEXTX,LEXI,LEXS,LEXS2,LEX1,LEX2,LEXOK,LEXP,LEXT1,LEXT2,LEXSG,LEXSGI,LEXCT
 S LEXOR=$G(X),LEXTX=$G(Y)
 S LEXS="I;1^II;2^III;3^IV;4^V;5^VI;6^VII;7"
 S LEXS=LEXS_"^VIII;8^IX;9^X;10^XI;11^XII;12"
 S LEXT1=LEXOR_" ",LEXT2=LEXTX_" ",LEXOK=0
 Q:(LEXT1_LEXT2)'["TYPE"&((LEXT1_LEXT2)'["OTH") 0
 F LEXP=1:1 Q:'$L($P(LEXS,"^",LEXP))  D  Q:LEXOK'=0
 . S LEX1=$P($P(LEXS,"^",LEXP),";",1),LEX2=$P($P(LEXS,"^",LEXP),";",2)
 . I LEXT1[("TYPE "_LEX1_" "),LEXT2[("TYPE "_LEX1_" ") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX1_","),LEXT2[("TYPE "_LEX1_",") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX1_" "),LEXT2[("TYPE "_LEX2_" ") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX1_","),LEXT2[("TYPE "_LEX2_",") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX2_" "),LEXT2[("TYPE "_LEX2_" ") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX2_","),LEXT2[("TYPE "_LEX2_",") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX2_" "),LEXT2[("TYPE "_LEX1_" ") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX2_","),LEXT2[("TYPE "_LEX1_",") S LEXOK=1 Q
 . I LEXT1[LEX1 D
 . . I LEXTX'[("TYPE "_LEX2_" ")&(LEXTX'[("TYPE "_LEX1_" ")) D
 . . . I LEXTX'[("TYPE "_LEX2_",")&(LEXTX'[("TYPE "_LEX1_",")) D
 . . . . I LEXT2["OTHER"!(LEXT2["OTH ") S LEXOK=1 Q
 . I LEXT1[("TYPE "_LEX2_" ") D
 . . I LEXTX'[("TYPE "_LEX2_" ")&(LEXTX'[("TYPE "_LEX1_" ")) D
 . . . I LEXTX'[("TYPE "_LEX2_",")&(LEXTX'[("TYPE "_LEX1_",")) D
 . . . . I LEXT2["OTHER"!(LEXT2["OTH ") S LEXOK=1 Q
 Q LEXOK
TM(X,Y) ;   Trim Y
 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
SO(X,Y,Z) ;   Source Code
 N LEXEF,LEXHI,LEXHIS,LEXPER,LEXS,LEXSO,LEXSRI,LEXE,LEXSAB
 N LEXCDT,LEXSTA,LEXTSO S LEXE=+($G(X))
 S LEXSAB=$G(Y),LEXCDT=$G(Z) Q:LEXE'>0 ""
 Q:'$D(^LEX(757.01,+LEXE,0)) ""  Q:$L(LEXSAB)'=3 ""
 Q:'$D(^LEX(757.03,"ASAB",LEXSAB)) ""
 S:LEXCDT'?7N LEXCDT=$$DT^XLFDT
 S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:LEXSRI'>0 ""
 Q:'$D(^LEX(757.03,LEXSRI,0)) ""  S LEXS=0,LEXSO=""
 F  S LEXS=$O(^LEX(757.02,"B",LEXE,LEXS)) Q:+LEXS'>0  D  Q:$L(LEXSO)
 . Q:$P($G(^LEX(757.02,LEXS,0)),"^",3)'=LEXSRI
 . S LEXEF=$O(^LEX(757.02,LEXS,4,"B",(LEXCDT+.001)),-1) Q:LEXEF'?7N
 . S LEXHI=$O(^LEX(757.02,LEXS,4,"B",+LEXEF," "),-1) Q:LEXHI'>0
 . S LEXHIS=$G(^LEX(757.02,LEXS,4,LEXHI,0))
 . S LEXSTA=$P(LEXHIS,"^",2),LEXPER=$P($G(^LEX(757.02,LEXS,0)),"^",5)
 . I LEXSTA>0,LEXPER>0 S LEXSO=$P($G(^LEX(757.02,LEXS,0)),"^",2)
 . I LEXSTA>0 S LEXTSO=$P($G(^LEX(757.02,LEXS,0)),"^",2)
 S:'$L(LEXSO) LEXSO=$G(LEXTSO) S X=LEXSO
 Q X
LA(X,Y,Z) ;   Last Activation
 N LEX,LEXD,LEXSRI,LEXT,LEXTD,LEXS,LEXSAB,LEXCDT S LEXTD=$$DT^XLFDT
 S LEXS=$G(X),LEXSAB=$G(Y),LEXCDT=$G(Z) Q:'$L(LEXSAB) LEXTD+1
 S LEXSRI=$O(^LEX(757.03,"ASAB",LEXSAB,0))
 Q:+LEXSRI'>0 (LEXTD+2)  S LEXD=" ",LEXT=""
 S:$P($G(LEXCDT),".",1)?7N LEXD=($P($G(LEXCDT),".",1))+.001
 F  S LEXD=$O(^LEX(757.02,"ACT",(LEXS_" "),3,LEXD),-1) Q:LEXD'?7N  D
 . S LEX=0
 . F  S LEX=$O(^LEX(757.02,"ACT",(LEXS_" "),3,LEXD,LEX)) Q:+LEX'>0  D
 . . I $P($G(^LEX(757.02,LEX,0)),"^",3)=LEXSRI D
 . . . S LEXT=LEXD,LEX=$O(^LEX(757.02," "),-1)+1,LEXD=0
 I $L(LEXT) D
 . S LEXD=" ",LEXT=""
 . F  S LEXD=$O(^LEX(757.02,"ACT",(LEXS_" "),1,LEXD),-1) Q:LEXD'?7N  D
 . . S LEX=0
 . . F  S LEX=$O(^LEX(757.02,"ACT",(LEXS_" "),1,LEXD,LEX)) Q:+LEX'>0  D
 . . . I $P($G(^LEX(757.02,LEX,0)),"^",3)=LEXSRI D
 . . . . S LEXT=LEXD,LEX=$O(^LEX(757.02," "),-1)+1,LEXD=0
 S:LEXT'?7N LEXT=LEXTD
 Q LEXT
SA(LEXA) ;   Show Array
 S LEXA=$G(LEXA) Q:'$L(LEXA)  Q:$L(LEXA)>8
 F  S LEXA=$Q(@LEXA) Q:'$L(LEXA)  D
 . W !,LEXA,"=",@LEXA
 Q