- 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 Feb 18, 2025@23:29:29 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
