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