- LEXXGP2 ;ISL/KER - Global Post-Install (Repair Expressions) ;12/19/2014
- ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
- ;
- ; Global Variables
- ; ^TMP("LEXASL") SACC 2.3.2.5.1
- ; ^TMP("LEXASLU") SACC 2.3.2.5.1
- ; ^TMP("LEXAWRD") SACC 2.3.2.5.1
- ; ^TMP("LEXAWRDU") SACC 2.3.2.5.1
- ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- ; ^TMP("LEXXGPDAT") SACC 2.3.2.5.1
- ; ^TMP("LEXXGPRPT") SACC 2.3.2.5.1
- ; ^TMP("LEXXGPTIM") SACC 2.3.2.5.1
- ;
- ; External References
- ; $$S^%ZTLOAD ICR 10063
- ; $$UP^XLFSTR ICR 10104
- ;
- ; Local Variables NEWed or KILLed in LEXXGP1
- ; LEXFIR,LEXFUL,LEXMAIL,LEXQUIT,ZTQUEUED,ZTSK
- ;
- Q
- ASLB ; ASL String Length Index Build 6.5 minutes
- N LEXA,LEXBEG,LEXBEGD,LEXBEGT,LEXC,LEXCHK,LEXDF,LEXE,LEXELP,LEXEND,LEXENDT,LEXM
- N LEXN,LEXO,LEXP,LEXRT,LEXS,LEXT,LEXTK,LEXTKN,LEXTXT S LEXBEG=$$BEG^LEXXGP1
- S:'$D(LEXQUIT) LEXQUIT="ASLB" S LEXTXT="Build 'ASL' String Length Index"
- I +($G(ZTSK))>0 S LEXCHK=$$S^%ZTLOAD((LEXTXT_" in file 757.01"))
- S LEXRT="" S:$D(^LEX(757.01,"AWRD")) LEXRT="^LEX(757.01,""AWRD"","
- S:$D(^TMP("LEXAWRD",$J)) LEXRT="^TMP(""LEXAWRD"","_$J_"," Q:'$L(LEXRT)
- ; For each Word
- S (LEXFIR,LEXFC,LEXTK)=""
- F S LEXTK=$O(@(LEXRT_""""_LEXTK_""")")) Q:'$L(LEXTK) D
- . N LEXP,LEXS,LEXC,LEXF,LEXTKN S LEXTKN=LEXTK
- . F Q:$E(LEXTKN,1)'=" " S LEXTKN=$E(LEXTKN,2,$L(LEXTKN))
- . F Q:$E(LEXTKN,$L(LEXTKN))'=" " S LEXTKN=$E(LEXTKN,1,($L(LEXTKN)-1))
- . S LEXF=$E(LEXTKN,1)
- . S LEXFIR=LEXF S:LEXFC'[LEXF LEXFC=LEXFC_LEXF
- . ; Count the occurrences of each string
- . F LEXP=1:1:$L(LEXTKN) S LEXS=$$UP^XLFSTR($E(LEXTKN,1,LEXP)) D
- . . Q:'$L($G(LEXS)) I '$D(^TMP("LEXASLU",$J,LEXS)) D
- . . . N LEXE,LEXM,LEXO,LEXT,LEXA,LEXN S (LEXA,LEXN,LEXT)=0
- . . . S LEXT=$$SCT(LEXS) I +($G(LEXT))>0 D
- . . . . K ^TMP("LEXASL",$J,LEXS)
- . . . . S ^TMP("LEXASL",$J,LEXS,LEXT)=""
- . . S ^TMP("LEXASLU",$J,LEXS)=""
- H 1 S LEXEND=$$END^LEXXGP1 D SAV^LEXXGP3(LEXBEG,LEXEND,LEXTXT)
- S LEXELP=$$ELP^LEXXGP1(LEXBEG,LEXEND),LEXBEGD=$$ED^LEXXGP1(LEXBEG)
- S LEXBEGT=$$ET^LEXXGP1(LEXBEG),LEXENDT=$$ET^LEXXGP1(LEXEND),LEXDF=$$DF^LEXXGP1(LEXBEG)
- S LEXTXT=$G(LEXTXT)_$J(" ",(35-$L($G(LEXTXT))))
- S LEXTXT=LEXTXT_LEXDF_" "_LEXBEGT_" "_LEXENDT_" "_LEXELP
- S LEXTXT=" "_LEXTXT W:'$D(ZTQUEUED) !,LEXTXT
- D ASLR I $G(LEXQUIT)="ASLB" D
- . D:$D(LEXMAIL) XM^LEXXGP3
- . K ^TMP("LEXASL",$J),^TMP("LEXASLU",$J),^TMP("LEXAWRD",$J),^TMP("LEXAWRDU",$J)
- . K ^TMP("LEXTKN",$J),^TMP("LEXXGPDAT",$J),^TMP("LEXXGPTIM",$J),^TMP("LEXXGPRPT",$J)
- Q
- ASLR ; ASL String Length Index Replace 0.5 minutes
- N LEX1,LEX2,LEX3,LEXBEG,LEXBEGD,LEXBEGT,LEXC,LEXCHK,LEXCHR,LEXCHRS,LEXCOM,LEXCTL
- N LEXDF,LEXELP,LEXEND,LEXENDT,LEXIT,LEXLTKN,LEXND,LEXNOD,LEXSTR,LEXTK,LEXTK1
- N LEXTK2,LEXTK3,LEXTK4,LEXTK5,LEXTMP,LEXTTKN,LEXTXT,LEXVAL S (LEX1,LEX2,LEX3)=0
- Q:'$D(LEXQUIT) S LEXBEG=$$BEG^LEXXGP1,LEXTXT="Replace 'ASL' String Length Index"
- I +($G(ZTSK))>0 S LEXCHK=$$S^%ZTLOAD((LEXTXT_" in file 757.01"))
- N LEXCHR,LEXCHRS D CHRS S LEXCHR=""
- F S LEXCHR=$O(LEXCHRS(LEXCHR)) Q:'$L(LEXCHR) D
- . ; For strings beginning with character
- . N LEXLTKN,LEXTTKN,LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5,LEXTK,LEXIT
- . ; Delete strings from the ^LEX global
- . S (LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5)=""
- . S LEXTK1=$C($A(LEXCHR)-1)_"~",LEXTK2=LEXCHR,LEXTK3=LEXCHR_" "
- . S:LEXCHR?1N LEXTK4=LEXCHR-.00000001
- . S:LEXCHR="." LEXTK5=.00000001
- . F LEXTK=LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5 D
- . . Q:'$L(LEXTK) S (LEXLTKN,LEXTTKN)=LEXTK S LEXIT=0
- . . F S LEXLTKN=$O(^LEX(757.01,"ASL",LEXLTKN)) D Q:LEXIT>0
- . . . S:'$L(LEXLTKN) LEXIT=1 S:$E(LEXLTKN,1)'=LEXCHR LEXIT=1
- . . . Q:LEXIT>0 N LEXNOD,LEXCTL
- . . . S LEXNOD="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_")"
- . . . S LEXCTL="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_","
- . . . F S LEXNOD=$Q(@LEXNOD) Q:'$L(LEXNOD)!(LEXNOD'[LEXCTL) D
- . . . . N LEXTMP,LEXND S LEXTMP=$TR(LEXLTKN,"""","")
- . . . . S LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_")"
- . . . . K @LEXND S LEX1=+($G(LEX1))+1
- . ; Add strings to the ^LEX global
- . F LEXTTKN=LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5 D
- . . Q:'$L(LEXTTKN) N LEXC,LEXIT S LEXIT=0,LEXC=LEXTTKN
- . . F S LEXTTKN=$O(^TMP("LEXASL",$J,LEXTTKN)) Q:'$L(LEXTTKN) D Q:LEXIT>0
- . . . Q:$E(LEXTTKN,1)'=LEXCHR
- . . . N LEXNOD,LEXCTL S LEXNOD="^TMP(""LEXASL"","_$J_","_$$QQ(LEXTTKN)_")"
- . . . S LEXCTL="^TMP(""LEXASL"","_$J_","_$$QQ(LEXTTKN)_","
- . . . F S LEXNOD=$Q(@LEXNOD) Q:'$L(LEXNOD)!(LEXNOD'[LEXCTL) D
- . . . . N LEXSTR,LEXVAL,LEXND,LEXTMP S LEXSTR=$P($P(LEXNOD,(","_$J_","),2),",",1)
- . . . . S LEXVAL=+$P($P(LEXNOD,(","_$J_","),2),",",2) Q:'$L(LEXSTR) Q:+LEXVAL'>0
- . . . . S LEXTMP=$TR(LEXSTR,"""",""),LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXTMP)_")" K @LEXND
- . . . . S LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXTMP)_","_LEXVAL_")"
- . . . . S @LEXND="" S LEX3=+($G(LEX3))+1
- . ; Repeat for all characters
- H 1 S LEXEND=$$END^LEXXGP1 D SAV^LEXXGP3(LEXBEG,LEXEND,LEXTXT)
- S LEXELP=$$ELP^LEXXGP1(LEXBEG,LEXEND),LEXBEGD=$$ED^LEXXGP1(LEXBEG)
- S LEXBEGT=$$ET^LEXXGP1(LEXBEG),LEXENDT=$$ET^LEXXGP1(LEXEND),LEXDF=$$DF^LEXXGP1(LEXBEG)
- S LEXTXT=$G(LEXTXT)_$J(" ",(35-$L($G(LEXTXT))))
- S LEXTXT=LEXTXT_LEXDF_" "_LEXBEGT_" "_LEXENDT_" "_LEXELP
- S LEXTXT=" "_LEXTXT W:'$D(ZTQUEUED) !,LEXTXT
- I LEX3>0,$D(LEXFUL) D
- . S LEXCOM=LEX3_" 'ASL' Index Node"_$S(LEX3>1:"s",1:"")
- . D SAV^LEXXGP3(LEXBEG,"","",LEXCOM) W:'$D(ZTQUEUED) !," ",LEXCOM
- Q
- ;
- ; Miscellaneous
- QQ(X) ; Set Quotes
- N LEXS,LEXT S LEXS=$TR($G(X),"""",""),LEXT=0
- S:$TR(LEXS,".","")'?1N.N LEXT=1 I $TR(LEXS,".","")?1N.N S:$L(+LEXS)'=$L(LEXS) LEXT=1
- S X=LEXS S:LEXT=1 X=""""_LEXS_""""
- Q X
- SCT(X) ; String Count (exact string)
- N LEX,LEXA,LEXE,LEXIT,LEXM,LEXN,LEXO,LEXOUT,LEXP,LEXRT,LEXRT2,LEXS,LEXT,LEXTKN
- S LEXS=$$UP^XLFSTR($G(X)) Q:'$L(LEXS) 0 S LEXRT="" S:$D(^LEX(757.01,"AWRD")) LEXRT="^LEX(757.01,""AWRD"","
- S:$D(^TMP("LEXAWRD",$J)) LEXRT="^TMP(""LEXAWRD"","_$J_"," Q:'$L(LEXRT) 0 S (LEXA,LEXN,LEXT)=0
- S:$L(LEXS)>1 LEXO=$E(LEXS,1,($L(LEXS)-1))_$C(($A($E(LEXS,$L(LEXS)))-1))_"~"
- S:$L(LEXS)=1 LEXO=$C(($A(LEXS)-1))_"~" S LEXIT=0
- F S LEXO=$O(@(LEXRT_""""_LEXO_""")")) D Q:LEXIT>0
- . S:'$L(LEXO) LEXIT=1 S:$E(LEXO,1,$L(LEXS))'=LEXS LEXIT=1
- . Q:LEXIT>0 N LEXM S LEXM=0 F S LEXM=$O(@(LEXRT_""""_LEXO_""","_LEXM_")")) Q:+LEXM'>0 D
- . . N LEXE,LEXRT2 S LEXE=0,LEXRT2=LEXRT_""""_LEXO_""","_LEXM_","
- . . F S LEXE=$O(@(LEXRT2_LEXE_")")) Q:+LEXE'>0 S LEXT=LEXT+1,LEXA=LEXA+1
- I $TR(LEXS,".","")?1N.N,$L(LEXS,".")'>2 I +LEXS=LEXS D
- . N LEXFC S LEXFC=$E(LEXS,1) S:$E(LEXS,1)?1N LEXO=LEXS-.000000001
- . S:$E(LEXS,1)="." LEXO=.000000001 S LEXIT=0
- . F S LEXO=$O(@(LEXRT_+LEXO_")")) D Q:LEXIT>0 Q:'$L(LEXO)
- . . S:LEXFC?1N&($E(LEXO,1)'?1N) LEXIT=1
- . . S:LEXFC?1P&($E(LEXO,1)'?1P) LEXIT=1 Q:LEXIT>0
- . . Q:'$L(LEXO) Q:$E(LEXO,1,$L(LEXS))'=LEXS N LEXM S LEXM=0
- . . F S LEXM=$O(@(LEXRT_+LEXO_","_LEXM_")")) Q:+LEXM'>0 D
- . . . N LEXE,LEXRT2 S LEXE=0,LEXRT2=LEXRT_+LEXO_","_LEXM_","
- . . . F S LEXE=$O(@(LEXRT2_LEXE_")")) Q:+LEXE'>0 S LEXT=LEXT+1,LEXN=LEXN+1
- S X=LEXT
- Q X
- CHRS ; Get Characters - Sets LEXCHRS
- N LEXCHR,LEXRT,LEXRT1,LEXRT2,LEXTK K LEXCHRS S LEXRT1="^LEX(757.01,""AWRD"","
- S LEXRT2="^TMP(""LEXAWRD"","_$J_"," F LEXRT=LEXRT1,LEXRT2 D
- . N LEXTK S LEXTK="#" F S LEXTK=$O(@(LEXRT_""""_LEXTK_""")")) Q:'$L(LEXTK) D
- . . N LEXCHR S LEXCHR=$E($TR(LEXTK," ",""),1) S LEXTK=$E(LEXTK,1)_"~"
- . . S:$L(LEXCHR) LEXCHRS(LEXCHR)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXGP2 7600 printed Feb 18, 2025@23:36:20 Page 2
- LEXXGP2 ;ISL/KER - Global Post-Install (Repair Expressions) ;12/19/2014
- +1 ;;2.0;LEXICON UTILITY;**80,86**;Sep 23, 1996;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; ^TMP("LEXASL") SACC 2.3.2.5.1
- +5 ; ^TMP("LEXASLU") SACC 2.3.2.5.1
- +6 ; ^TMP("LEXAWRD") SACC 2.3.2.5.1
- +7 ; ^TMP("LEXAWRDU") SACC 2.3.2.5.1
- +8 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
- +9 ; ^TMP("LEXXGPDAT") SACC 2.3.2.5.1
- +10 ; ^TMP("LEXXGPRPT") SACC 2.3.2.5.1
- +11 ; ^TMP("LEXXGPTIM") SACC 2.3.2.5.1
- +12 ;
- +13 ; External References
- +14 ; $$S^%ZTLOAD ICR 10063
- +15 ; $$UP^XLFSTR ICR 10104
- +16 ;
- +17 ; Local Variables NEWed or KILLed in LEXXGP1
- +18 ; LEXFIR,LEXFUL,LEXMAIL,LEXQUIT,ZTQUEUED,ZTSK
- +19 ;
- +20 QUIT
- ASLB ; ASL String Length Index Build 6.5 minutes
- +1 NEW LEXA,LEXBEG,LEXBEGD,LEXBEGT,LEXC,LEXCHK,LEXDF,LEXE,LEXELP,LEXEND,LEXENDT,LEXM
- +2 NEW LEXN,LEXO,LEXP,LEXRT,LEXS,LEXT,LEXTK,LEXTKN,LEXTXT
- SET LEXBEG=$$BEG^LEXXGP1
- +3 if '$DATA(LEXQUIT)
- SET LEXQUIT="ASLB"
- SET LEXTXT="Build 'ASL' String Length Index"
- +4 IF +($GET(ZTSK))>0
- SET LEXCHK=$$S^%ZTLOAD((LEXTXT_" in file 757.01"))
- +5 SET LEXRT=""
- if $DATA(^LEX(757.01,"AWRD"))
- SET LEXRT="^LEX(757.01,""AWRD"","
- +6 if $DATA(^TMP("LEXAWRD",$JOB))
- SET LEXRT="^TMP(""LEXAWRD"","_$JOB_","
- if '$LENGTH(LEXRT)
- QUIT
- +7 ; For each Word
- +8 SET (LEXFIR,LEXFC,LEXTK)=""
- +9 FOR
- SET LEXTK=$ORDER(@(LEXRT_""""_LEXTK_""")"))
- if '$LENGTH(LEXTK)
- QUIT
- Begin DoDot:1
- +10 NEW LEXP,LEXS,LEXC,LEXF,LEXTKN
- SET LEXTKN=LEXTK
- +11 FOR
- if $EXTRACT(LEXTKN,1)'=" "
- QUIT
- SET LEXTKN=$EXTRACT(LEXTKN,2,$LENGTH(LEXTKN))
- +12 FOR
- if $EXTRACT(LEXTKN,$LENGTH(LEXTKN))'=" "
- QUIT
- SET LEXTKN=$EXTRACT(LEXTKN,1,($LENGTH(LEXTKN)-1))
- +13 SET LEXF=$EXTRACT(LEXTKN,1)
- +14 SET LEXFIR=LEXF
- if LEXFC'[LEXF
- SET LEXFC=LEXFC_LEXF
- +15 ; Count the occurrences of each string
- +16 FOR LEXP=1:1:$LENGTH(LEXTKN)
- SET LEXS=$$UP^XLFSTR($EXTRACT(LEXTKN,1,LEXP))
- Begin DoDot:2
- +17 if '$LENGTH($GET(LEXS))
- QUIT
- IF '$DATA(^TMP("LEXASLU",$JOB,LEXS))
- Begin DoDot:3
- +18 NEW LEXE,LEXM,LEXO,LEXT,LEXA,LEXN
- SET (LEXA,LEXN,LEXT)=0
- +19 SET LEXT=$$SCT(LEXS)
- IF +($GET(LEXT))>0
- Begin DoDot:4
- +20 KILL ^TMP("LEXASL",$JOB,LEXS)
- +21 SET ^TMP("LEXASL",$JOB,LEXS,LEXT)=""
- End DoDot:4
- End DoDot:3
- +22 SET ^TMP("LEXASLU",$JOB,LEXS)=""
- End DoDot:2
- End DoDot:1
- +23 HANG 1
- SET LEXEND=$$END^LEXXGP1
- DO SAV^LEXXGP3(LEXBEG,LEXEND,LEXTXT)
- +24 SET LEXELP=$$ELP^LEXXGP1(LEXBEG,LEXEND)
- SET LEXBEGD=$$ED^LEXXGP1(LEXBEG)
- +25 SET LEXBEGT=$$ET^LEXXGP1(LEXBEG)
- SET LEXENDT=$$ET^LEXXGP1(LEXEND)
- SET LEXDF=$$DF^LEXXGP1(LEXBEG)
- +26 SET LEXTXT=$GET(LEXTXT)_$JUSTIFY(" ",(35-$LENGTH($GET(LEXTXT))))
- +27 SET LEXTXT=LEXTXT_LEXDF_" "_LEXBEGT_" "_LEXENDT_" "_LEXELP
- +28 SET LEXTXT=" "_LEXTXT
- if '$DATA(ZTQUEUED)
- WRITE !,LEXTXT
- +29 DO ASLR
- IF $GET(LEXQUIT)="ASLB"
- Begin DoDot:1
- +30 if $DATA(LEXMAIL)
- DO XM^LEXXGP3
- +31 KILL ^TMP("LEXASL",$JOB),^TMP("LEXASLU",$JOB),^TMP("LEXAWRD",$JOB),^TMP("LEXAWRDU",$JOB)
- +32 KILL ^TMP("LEXTKN",$JOB),^TMP("LEXXGPDAT",$JOB),^TMP("LEXXGPTIM",$JOB),^TMP("LEXXGPRPT",$JOB)
- End DoDot:1
- +33 QUIT
- ASLR ; ASL String Length Index Replace 0.5 minutes
- +1 NEW LEX1,LEX2,LEX3,LEXBEG,LEXBEGD,LEXBEGT,LEXC,LEXCHK,LEXCHR,LEXCHRS,LEXCOM,LEXCTL
- +2 NEW LEXDF,LEXELP,LEXEND,LEXENDT,LEXIT,LEXLTKN,LEXND,LEXNOD,LEXSTR,LEXTK,LEXTK1
- +3 NEW LEXTK2,LEXTK3,LEXTK4,LEXTK5,LEXTMP,LEXTTKN,LEXTXT,LEXVAL
- SET (LEX1,LEX2,LEX3)=0
- +4 if '$DATA(LEXQUIT)
- QUIT
- SET LEXBEG=$$BEG^LEXXGP1
- SET LEXTXT="Replace 'ASL' String Length Index"
- +5 IF +($GET(ZTSK))>0
- SET LEXCHK=$$S^%ZTLOAD((LEXTXT_" in file 757.01"))
- +6 NEW LEXCHR,LEXCHRS
- DO CHRS
- SET LEXCHR=""
- +7 FOR
- SET LEXCHR=$ORDER(LEXCHRS(LEXCHR))
- if '$LENGTH(LEXCHR)
- QUIT
- Begin DoDot:1
- +8 ; For strings beginning with character
- +9 NEW LEXLTKN,LEXTTKN,LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5,LEXTK,LEXIT
- +10 ; Delete strings from the ^LEX global
- +11 SET (LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5)=""
- +12 SET LEXTK1=$CHAR($ASCII(LEXCHR)-1)_"~"
- SET LEXTK2=LEXCHR
- SET LEXTK3=LEXCHR_" "
- +13 if LEXCHR?1N
- SET LEXTK4=LEXCHR-.00000001
- +14 if LEXCHR="."
- SET LEXTK5=.00000001
- +15 FOR LEXTK=LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5
- Begin DoDot:2
- +16 if '$LENGTH(LEXTK)
- QUIT
- SET (LEXLTKN,LEXTTKN)=LEXTK
- SET LEXIT=0
- +17 FOR
- SET LEXLTKN=$ORDER(^LEX(757.01,"ASL",LEXLTKN))
- Begin DoDot:3
- +18 if '$LENGTH(LEXLTKN)
- SET LEXIT=1
- if $EXTRACT(LEXLTKN,1)'=LEXCHR
- SET LEXIT=1
- +19 if LEXIT>0
- QUIT
- NEW LEXNOD,LEXCTL
- +20 SET LEXNOD="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_")"
- +21 SET LEXCTL="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_","
- +22 FOR
- SET LEXNOD=$QUERY(@LEXNOD)
- if '$LENGTH(LEXNOD)!(LEXNOD'[LEXCTL)
- QUIT
- Begin DoDot:4
- +23 NEW LEXTMP,LEXND
- SET LEXTMP=$TRANSLATE(LEXLTKN,"""","")
- +24 SET LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXLTKN)_")"
- +25 KILL @LEXND
- SET LEX1=+($GET(LEX1))+1
- End DoDot:4
- End DoDot:3
- if LEXIT>0
- QUIT
- End DoDot:2
- +26 ; Add strings to the ^LEX global
- +27 FOR LEXTTKN=LEXTK1,LEXTK2,LEXTK3,LEXTK4,LEXTK5
- Begin DoDot:2
- +28 if '$LENGTH(LEXTTKN)
- QUIT
- NEW LEXC,LEXIT
- SET LEXIT=0
- SET LEXC=LEXTTKN
- +29 FOR
- SET LEXTTKN=$ORDER(^TMP("LEXASL",$JOB,LEXTTKN))
- if '$LENGTH(LEXTTKN)
- QUIT
- Begin DoDot:3
- +30 if $EXTRACT(LEXTTKN,1)'=LEXCHR
- QUIT
- +31 NEW LEXNOD,LEXCTL
- SET LEXNOD="^TMP(""LEXASL"","_$JOB_","_$$QQ(LEXTTKN)_")"
- +32 SET LEXCTL="^TMP(""LEXASL"","_$JOB_","_$$QQ(LEXTTKN)_","
- +33 FOR
- SET LEXNOD=$QUERY(@LEXNOD)
- if '$LENGTH(LEXNOD)!(LEXNOD'[LEXCTL)
- QUIT
- Begin DoDot:4
- +34 NEW LEXSTR,LEXVAL,LEXND,LEXTMP
- SET LEXSTR=$PIECE($PIECE(LEXNOD,(","_$JOB_","),2),",",1)
- +35 SET LEXVAL=+$PIECE($PIECE(LEXNOD,(","_$JOB_","),2),",",2)
- if '$LENGTH(LEXSTR)
- QUIT
- if +LEXVAL'>0
- QUIT
- +36 SET LEXTMP=$TRANSLATE(LEXSTR,"""","")
- SET LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXTMP)_")"
- KILL @LEXND
- +37 SET LEXND="^LEX(757.01,""ASL"","_$$QQ(LEXTMP)_","_LEXVAL_")"
- +38 SET @LEXND=""
- SET LEX3=+($GET(LEX3))+1
- End DoDot:4
- End DoDot:3
- if LEXIT>0
- QUIT
- End DoDot:2
- +39 ; Repeat for all characters
- End DoDot:1
- +40 HANG 1
- SET LEXEND=$$END^LEXXGP1
- DO SAV^LEXXGP3(LEXBEG,LEXEND,LEXTXT)
- +41 SET LEXELP=$$ELP^LEXXGP1(LEXBEG,LEXEND)
- SET LEXBEGD=$$ED^LEXXGP1(LEXBEG)
- +42 SET LEXBEGT=$$ET^LEXXGP1(LEXBEG)
- SET LEXENDT=$$ET^LEXXGP1(LEXEND)
- SET LEXDF=$$DF^LEXXGP1(LEXBEG)
- +43 SET LEXTXT=$GET(LEXTXT)_$JUSTIFY(" ",(35-$LENGTH($GET(LEXTXT))))
- +44 SET LEXTXT=LEXTXT_LEXDF_" "_LEXBEGT_" "_LEXENDT_" "_LEXELP
- +45 SET LEXTXT=" "_LEXTXT
- if '$DATA(ZTQUEUED)
- WRITE !,LEXTXT
- +46 IF LEX3>0
- IF $DATA(LEXFUL)
- Begin DoDot:1
- +47 SET LEXCOM=LEX3_" 'ASL' Index Node"_$SELECT(LEX3>1:"s",1:"")
- +48 DO SAV^LEXXGP3(LEXBEG,"","",LEXCOM)
- if '$DATA(ZTQUEUED)
- WRITE !," ",LEXCOM
- End DoDot:1
- +49 QUIT
- +50 ;
- +51 ; Miscellaneous
- QQ(X) ; Set Quotes
- +1 NEW LEXS,LEXT
- SET LEXS=$TRANSLATE($GET(X),"""","")
- SET LEXT=0
- +2 if $TRANSLATE(LEXS,".","")'?1N.N
- SET LEXT=1
- IF $TRANSLATE(LEXS,".","")?1N.N
- if $LENGTH(+LEXS)'=$LENGTH(LEXS)
- SET LEXT=1
- +3 SET X=LEXS
- if LEXT=1
- SET X=""""_LEXS_""""
- +4 QUIT X
- SCT(X) ; String Count (exact string)
- +1 NEW LEX,LEXA,LEXE,LEXIT,LEXM,LEXN,LEXO,LEXOUT,LEXP,LEXRT,LEXRT2,LEXS,LEXT,LEXTKN
- +2 SET LEXS=$$UP^XLFSTR($GET(X))
- if '$LENGTH(LEXS)
- QUIT 0
- SET LEXRT=""
- if $DATA(^LEX(757.01,"AWRD"))
- SET LEXRT="^LEX(757.01,""AWRD"","
- +3 if $DATA(^TMP("LEXAWRD",$JOB))
- SET LEXRT="^TMP(""LEXAWRD"","_$JOB_","
- if '$LENGTH(LEXRT)
- QUIT 0
- SET (LEXA,LEXN,LEXT)=0
- +4 if $LENGTH(LEXS)>1
- SET LEXO=$EXTRACT(LEXS,1,($LENGTH(LEXS)-1))_$CHAR(($ASCII($EXTRACT(LEXS,$LENGTH(LEXS)))-1))_"~"
- +5 if $LENGTH(LEXS)=1
- SET LEXO=$CHAR(($ASCII(LEXS)-1))_"~"
- SET LEXIT=0
- +6 FOR
- SET LEXO=$ORDER(@(LEXRT_""""_LEXO_""")"))
- Begin DoDot:1
- +7 if '$LENGTH(LEXO)
- SET LEXIT=1
- if $EXTRACT(LEXO,1,$LENGTH(LEXS))'=LEXS
- SET LEXIT=1
- +8 if LEXIT>0
- QUIT
- NEW LEXM
- SET LEXM=0
- FOR
- SET LEXM=$ORDER(@(LEXRT_""""_LEXO_""","_LEXM_")"))
- if +LEXM'>0
- QUIT
- Begin DoDot:2
- +9 NEW LEXE,LEXRT2
- SET LEXE=0
- SET LEXRT2=LEXRT_""""_LEXO_""","_LEXM_","
- +10 FOR
- SET LEXE=$ORDER(@(LEXRT2_LEXE_")"))
- if +LEXE'>0
- QUIT
- SET LEXT=LEXT+1
- SET LEXA=LEXA+1
- End DoDot:2
- End DoDot:1
- if LEXIT>0
- QUIT
- +11 IF $TRANSLATE(LEXS,".","")?1N.N
- IF $LENGTH(LEXS,".")'>2
- IF +LEXS=LEXS
- Begin DoDot:1
- +12 NEW LEXFC
- SET LEXFC=$EXTRACT(LEXS,1)
- if $EXTRACT(LEXS,1)?1N
- SET LEXO=LEXS-.000000001
- +13 if $EXTRACT(LEXS,1)="."
- SET LEXO=.000000001
- SET LEXIT=0
- +14 FOR
- SET LEXO=$ORDER(@(LEXRT_+LEXO_")"))
- Begin DoDot:2
- +15 if LEXFC?1N&($EXTRACT(LEXO,1)'?1N)
- SET LEXIT=1
- +16 if LEXFC?1P&($EXTRACT(LEXO,1)'?1P)
- SET LEXIT=1
- if LEXIT>0
- QUIT
- +17 if '$LENGTH(LEXO)
- QUIT
- if $EXTRACT(LEXO,1,$LENGTH(LEXS))'=LEXS
- QUIT
- NEW LEXM
- SET LEXM=0
- +18 FOR
- SET LEXM=$ORDER(@(LEXRT_+LEXO_","_LEXM_")"))
- if +LEXM'>0
- QUIT
- Begin DoDot:3
- +19 NEW LEXE,LEXRT2
- SET LEXE=0
- SET LEXRT2=LEXRT_+LEXO_","_LEXM_","
- +20 FOR
- SET LEXE=$ORDER(@(LEXRT2_LEXE_")"))
- if +LEXE'>0
- QUIT
- SET LEXT=LEXT+1
- SET LEXN=LEXN+1
- End DoDot:3
- End DoDot:2
- if LEXIT>0
- QUIT
- if '$LENGTH(LEXO)
- QUIT
- End DoDot:1
- +21 SET X=LEXT
- +22 QUIT X
- CHRS ; Get Characters - Sets LEXCHRS
- +1 NEW LEXCHR,LEXRT,LEXRT1,LEXRT2,LEXTK
- KILL LEXCHRS
- SET LEXRT1="^LEX(757.01,""AWRD"","
- +2 SET LEXRT2="^TMP(""LEXAWRD"","_$JOB_","
- FOR LEXRT=LEXRT1,LEXRT2
- Begin DoDot:1
- +3 NEW LEXTK
- SET LEXTK="#"
- FOR
- SET LEXTK=$ORDER(@(LEXRT_""""_LEXTK_""")"))
- if '$LENGTH(LEXTK)
- QUIT
- Begin DoDot:2
- +4 NEW LEXCHR
- SET LEXCHR=$EXTRACT($TRANSLATE(LEXTK," ",""),1)
- SET LEXTK=$EXTRACT(LEXTK,1)_"~"
- +5 if $LENGTH(LEXCHR)
- SET LEXCHRS(LEXCHR)=""
- End DoDot:2
- End DoDot:1
- +6 QUIT
