LEXRXF ;ISL/KER - Re-Index 757.21 B/C/AA ;05/23/2017
;;2.0;LEXICON UTILITY;**81,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757) SACC 1.3
; ^LEX(757.01) SACC 1.3
; ^LEX(757.011) SACC 1.3
; ^LEX(757.21) SACC 1.3
; ^LEXT(757.2) SACC 1.3
; ^TMP("LEXRX",$J) SACC 2.3.2.5.1
; ^TMP("LEXRXF",$J) SACC 2.3.2.5.1
; ^TMP("LEXTKN",$J) SACC 2.3.2.5.1
; ^TMP("LEXWRD",$J) SACC 2.3.2.5.1
;
; External References
; FILE^DID ICR 2052
; ^DIK ICR 10013
; IXALL^DIK ICR 10013
; $$FMDIFF^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXFIX Fix Index flag NEWed/KILLed by LEXRXXT
; LEXNAM Task name NEWed/KILLed by LEXRXXT
; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
; LEXTEST Test variable NEWed/KILLed by Developer
; ZTQUEUED Task flag NEWed/KILLed by Taskman
; ZTREQ Task Reqest NEWed/KILLed by Taskman
;
Q
EN ; Main Entry Point
R75721 ; Repair file 757.21
K ^TMP("LEXRXF",$J) D RB,RC,RAA,SET K ^TMP("LEXRXF",$J)
Q
RB ; Index ^LEX(757.21,"B",EXP,IEN)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
S LEXFI="757.21"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.21 ""B""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXFI=757.21,LEXIDX="B",LEXIDXT="^LEX(757.21,""B"",EXP,IEN)"
F S LEXSTR=$O(^LEX(LEXFI,LEXIDX,LEXSTR)) Q:'$L(LEXSTR) D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)) Q:+LEXIEN'>0 D
. . S LEXNDS=LEXNDS+1 N LEXOK,LEXEX S LEXEX=$P($G(^LEX(LEXFI,LEXIEN,0)),"^",1)
. . S LEXOK=0 S:LEXEX=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN) S:$L(LEXEX) ^LEX(LEXFI,LEXIDX,LEXEX,LEXIEN)=""
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK,X S DA=LEXIEN,X=$P($G(^LEX(LEXFI,DA,0)),"^",1) Q:'$L(X)
. I '$D(^LEX(LEXFI,LEXIDX,X,DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",X,?58," ",DA
. S:$L(X) ^LEX(LEXFI,LEXIDX,X,DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
H 1 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
Q
RC ; Index ^LEX(757.21,"C",EXP,IEN)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
S LEXFI="757.21"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.21 ""C""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXFI=757.21,LEXIDX="C",LEXIDXT="^LEX(757.21,""C"",EXP,IEN)"
F S LEXSTR=$O(^LEX(LEXFI,LEXIDX,LEXSTR)) Q:'$L(LEXSTR) D
. N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)) Q:+LEXIEN'>0 D
. . S LEXNDS=LEXNDS+1 N LEXOK,LEXEX,LEXEXP
. . S LEXEX=$P($G(^LEX(LEXFI,LEXIEN,0)),"^",1)
. . S LEXEXP=$E($$UP^XLFSTR($G(^LEX(757.01,+($G(LEXEX)),0))),1,63)
. . S LEXOK=0 S:LEXEXP=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,"C",LEXSTR,LEXIEN) S:$L(LEXEXP) ^LEX(LEXFI,"C",LEXEXP,LEXIEN)=""
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,$E(LEXSTR,1,28),?58," ",LEXIEN
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK,X,LEXEXP S DA=LEXIEN,X=$P($G(^LEX(LEXFI,DA,0)),"^",1),LEXEXP=$E($$UP^XLFSTR(^LEX(757.01,X,0)),1,63)
. Q:+X'>0 Q:'$L(LEXEXP)
. I '$D(^LEX(LEXFI,LEXIDX,LEXEXP,DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",$E(LEXEXP,1,20),?58," ",DA
. S ^LEX(LEXFI,LEXIDX,LEXEXP,DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
H 1 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
Q
RAA ; Index ^LEX(757.21,("A"_SUBSET),WORD,IEN)
; ^LEX(757.21,"ADEN",WORD,IEN)
; ^LEX(757.21,"AIMM",WORD,IEN)
; ^LEX(757.21,"ANUR",WORD,IEN)
; ^LEX(757.21,"ASOC",WORD,IEN)
; ^LEX(757.21,[etc],WORD,IEN)
;
S:$D(ZTQUEUED) ZTREQ="@" N LEXARY,LEXBEG,LEXCT,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT
N LEXIEN,LEXIT,LEXKEY,LEXKEYS,LEXMIS,LEXND,LEXSERR,LEXSIEN,LEXSNDS,LEXSTR,LEXTC,LEXTIM,X
S LEXFI="757.21" K ^TMP("LEXRXF",$J) S:'$L($G(LEXNAM)) LEXNAM="LEXRXONE"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.21 ""AA""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXSNDS)=0,LEXSTR="",LEXFI=757.21,LEXIDX=" "
S LEXFI=757.21,(LEXMIS,LEXIT)=0,LEXIDX="A" F S LEXIDX=$O(^LEX(757.21,LEXIDX)) Q:'$L(LEXIDX) D Q:LEXIT>0
. K ^TMP("LEXRXF",$J,LEXIDX) Q:$E(LEXIDX,1)'="A" Q:$L(LEXIDX)'=4
. N LEXTC,LEXSTR,LEXCT,LEXBEG,LEXEND,LEXTIM,LEXERR,LEXNDS
. S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,("Repairing File #757.21 """_LEXIDX_""""))
. S (LEXNDS,LEXERR)=0,LEXTIM="",LEXBEG=$$NOW^XLFDT,LEXSTR="",LEXCT=0
. I '$D(ZTQUEUED) W !,"^LEX(757.21,""",LEXIDX,""")"
. F S LEXSTR=$O(^LEX(757.21,LEXIDX,LEXSTR)) Q:'$L(LEXSTR) D
. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)) Q:+LEXIEN'>0 D
. . . N LEXEXI S LEXEXI=+($G(^LEX(757.21,+LEXIEN,0)))
. . . S LEXSNDS=+($G(LEXSNDS))+1,LEXNDS=+($G(LEXNDS))+1,^TMP("LEXRXF",$J,LEXIDX,"N")=LEXNDS,LEXCT=LEXCT+1
. . . I '$D(^LEX(757.21,LEXIEN,0)) D Q
. . . . S LEXERR=+($G(LEXERR))+1,^TMP("LEXRXF",$J,LEXIDX,"E")=LEXERR
. . . . K:'$D(LEXTEST) ^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)
. . . . I '$D(ZTQUEUED) W !,?8,757.21,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . . N LEXKEY,LEXKEYS,LEXDEA,LEXTTYP S LEXDEA=$$DEA(+LEXEXI) Q:+LEXDEA>0
. . . S LEXTTYP=$P($G(^LEX(757.01,+LEXEXI,1)),"^",2) Q:LEXTTYP=8
. . . K LEXKEYS D KEYS(LEXIEN,.LEXKEYS,LEXIDX)
. . . I '$D(LEXKEYS(LEXSTR)) D Q
. . . . S LEXERR=+($G(LEXERR))+1,^TMP("LEXRXF",$J,LEXIDX,"E")=LEXERR
. . . . K:'$D(LEXTEST) ^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)
. . . . I '$D(ZTQUEUED) W !,?8,757.21,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . . S LEXKEY="" F S LEXKEY=$O(LEXKEYS(LEXKEY)) Q:'$L(LEXKEY) D
. . . . N LEXND S LEXND="^LEX(757.21,"""_LEXIDX_""","""_LEXKEY_""","_+LEXIEN_")"
. . . . I '$D(@LEXND) S LEXMIS=+($G(LEXMIS))+1,LEXERR=+($G(LEXERR))+1,^TMP("LEXRXF",$J,LEXIDX,"E")=LEXERR
. . . . S:'$D(LEXTEST) @LEXND=""
. . . . W:'$D(ZTQUEUED)&('$D(@LEXND)) !,$J(LEXCT,6),?15,LEXND S @LEXND=""
. I '$D(ZTQUEUED),+($G(LEXCT))>0 D
. . I +($G(LEXERR))'>0 W ?22,$J(+($G(LEXCT)),12)," Tested"
. . I +($G(LEXERR))>0 W !,?22,$J(+($G(LEXCT)),12),"/",+($G(LEXERR))," Tested/Errors"
. H 1 S LEXEND=$$NOW^XLFDT,LEXTIM=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
. S:$E(LEXTIM,1)=" "&($E(LEXTIM,3)=":") LEXTIM=$TR(LEXTIM," ","0")
. S ^TMP("LEXRXF",$J,LEXIDX,"T")=LEXTIM
H 1 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
;
N LEXSIEN S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.12,LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXEX,LEXSS,LEXSSN,LEXKEY,LEXKEYS
. S LEXSS=+($P($G(^LEX(757.21,+LEXSIEN,0)),"^",2))
. S LEXSSN=$P($G(^LEXT(757.2,+LEXSS,5)),"^",2) Q:$L(LEXSSN)'=3 S LEXSSN="A"_LEXSSN
. K LEXKEYS D KEYS(LEXSIEN,.LEXKEYS,LEXSSN)
. S LEXKEY="" F S LEXKEY=$O(LEXKEYS(LEXKEY)) Q:'$L(LEXKEY) D
. . S ^LEX(757.21,LEXSSN,LEXKEY,LEXSIEN)=""
;
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
S (LEXSNDS,LEXSERR)=0,LEXIDX=" " F S LEXIDX=$O(^LEX(757.21,LEXIDX)) Q:'$L(LEXIDX) D
. Q:$L(LEXIDX)'>1 N LEXE,LEXN S LEXE=$G(^TMP("LEXRXF",$J,LEXIDX,"E")),LEXSERR=LEXSERR+LEXE
. S LEXN=$G(^TMP("LEXRXF",$J,LEXIDX,"N")),LEXSNDS=LEXSNDS+LEXN
D REP^LEXRXXS(LEXFI,LEXFI,"A***",LEXSNDS,LEXSERR,"^LEX(757.21,""A***"",WORD,IEN)",LEXELP)
S LEXIDX=" " F S LEXIDX=$O(^LEX(757.21,LEXIDX)) Q:'$L(LEXIDX) D
. Q:$L(LEXIDX)>1 N LEXE,LEXN S LEXE=$G(^TMP("LEXRXF",$J,LEXIDX,"E")),LEXSERR=LEXSERR+LEXE
. S LEXN=$G(^TMP("LEXRXF",$J,LEXIDX,"N")),LEXSNDS=LEXSNDS+LEXN
S ^TMP("LEXRX",$J,"TERR")=+($G(LEXSERR))
S LEXIDX=" " F S LEXIDX=$O(^LEX(757.21,LEXIDX)) Q:'$L(LEXIDX) D
. Q:LEXIDX="B" Q:LEXIDX="C"
. N LEXFI,LEXERR,LEXELP,LEXNDS,LEXIDXT S LEXFI=757.21
. S LEXERR=$G(^TMP("LEXRXF",$J,LEXIDX,"E"))
. S LEXNDS=$G(^TMP("LEXRXF",$J,LEXIDX,"N"))
. S LEXELP=$G(^TMP("LEXRXF",$J,LEXIDX,"T"))
. S LEXIDXT="^LEX(757.21,"""_LEXIDX_""",WORD,IEN)"
. S LEXERR=$S(+($G(LEXERR))>0:LEXERR,1:"")
. S LEXNDS=$S(+($G(LEXNDS))>0:LEXNDS,1:"")
. S LEXELP=$S($L($G(LEXELP))>0:LEXELP,1:"")
. D REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
K ^TMP("LEXRXF",$J)
Q
;
; Miscellaneous
KEYS(X,LEXARY,LEXIDX) ; Parse Sub-Set Expression into Keywords
N LEXSI,LEXEXI,LEXEXP,LEXI,LEXIEN,LEXK,LEXMC,LEXSIEN K LEXARY
S LEXSI=+($G(X)) Q:+LEXSI'>0 Q:'$D(^LEX(757.21,+LEXSI,0))
S LEXIDX=$G(LEXIDX) Q:'$L(LEXIDX) Q:$L(LEXIDX)'=4 Q:$E(LEXIDX,1)'="A"
S LEXIEN=+($G(^LEX(757.21,+LEXSI,0))) Q:'$D(^LEX(757.01,+LEXIEN,0))
S LEXMC=+($G(^LEX(757.01,LEXIEN,1))) Q:LEXMC'>0 Q:'$D(^LEX(757,+LEXMC,0))
S LEXEXI=0 F S LEXEXI=$O(^LEX(757.01,"AMC",+LEXMC,LEXEXI)) Q:+LEXEXI'>0 D
. N X,LEXEXP,LEXTTYP,LEXDEA,LEXI S LEXDEA=$$DEA(+LEXEXI) Q:+($G(LEXDEA))>0
. S LEXTTYP=+($P($G(^LEX(757.01,+LEXEXI,1)),"^",2)) Q:LEXTTYP=8
. S (X,LEXEXP)=$G(^LEX(757.01,+LEXEXI,0)) K ^TMP("LEXTKN",$J) D PTX^LEXTOKN
. S LEXI=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
. . S:$L($O(^TMP("LEXTKN",$J,LEXI,""))) LEXARY($O(^TMP("LEXTKN",$J,LEXI,"")))=""
. I $D(^LEX(757.01,+LEXEXI,5,"B")) D SUP(+LEXEXI,.LEXARY)
. I $D(^LEX(757.05,"AEXP",+LEXEXI)) D REP(+LEXEXI,.LEXARY)
K ^TMP("LEXTKN",$J)
Q
SUP(X,LEXARY) ; Supplemental Keywords
I $D(^LEX(757.01,+($G(X)),5,"B")) D
. N LEXK S LEXK="" F S LEXK=$O(^LEX(757.01,+($G(X)),5,"B",LEXK)) Q:'$L(LEXK) S LEXARY(LEXK)=""
Q
REP(X,LEXARY) ; Repacement/Linked Keywords
N LEXEXI,LEXLIEN,LEXSTR S LEXEXI=+($G(X)),LEXSTR="" I +LEXEXI>0 D
. S LEXLIEN=0 F S LEXLIEN=$O(^LEX(757.05,"AEXP",+LEXEXI,LEXLIEN)) Q:+LEXLIEN'>0 D
. . Q:'$D(^LEX(757.05,+LEXLIEN,1,"B",+LEXEXI)) N LEXN,LEXT,LEXE,LEXA
. . S LEXN=$G(^LEX(757.05,+LEXLIEN,0)),LEXT=$P(LEXN,"^",1),LEXE=$P(LEXN,"^",2),LEXA=$P(LEXN,"^",3)
. . Q:LEXA'="L" S:$L(LEXT) LEXARY(LEXT)=""
Q
SET ; Re-Index Subset file 757.21 (Set logic only)
Q:'$D(LEXSET) N LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
N LEXOUT,LEXMSG S LEXFI=757.21
D FILE^DID(LEXFI,"N","GLOBAL NAME","LEXOUT","LEXMSG")
S LEXRT=$G(LEXOUT("GLOBAL NAME")) Q:LEXRT'["^LEX"
S LEXPRE=$G(^TMP("LEXRX",$J,"T",1,"ELAP"))
S LEXBEG=$$NOW^XLFDT,LEXNM=$$FN^LEXRXXM(LEXFI)
S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,("Re-Indexing File #"_LEXFI))
Q:LEXTC=1 I '$D(ZTQUEUED) W !,?8,"Re-Indexing",!
N LEXIEN,LEXP1,LEXP2,LEXP3,LEXP4 S (LEXP3,LEXP4,LEXIEN)=0
S LEXP1=$P($G(^LEX(LEXFI,0)),"^",1),LEXP2=$P($G(^LEX(LEXFI,0)),"^",2)
F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. D:$D(LEXFIX) FIX(LEXIEN) I $D(^LEX(LEXFI,+LEXIEN,0)) S LEXP3=LEXIEN,LEXP4=LEXP4+1
S:LEXP3>0 $P(^LEX(LEXFI,0),"^",3)=LEXP3 S:LEXP4>0 $P(^LEX(LEXFI,0),"^",4)=LEXP4
I +($G(LEXP4))>0 N DIK S DIK="^LEX(757.21," D IXALL^DIK
Q:$D(LEXQ) H 1 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
S:$E(LEXELP,1)=" "&($E(LEXELP,3)=":") LEXELP=$TR(LEXELP," ","0")
D REP^LEXRXXS(LEXFI,LEXFI,"ALLIX",,,"Re-Index",LEXELP)
S LEXELP=$$ADDT^LEXRXXM(LEXELP,LEXPRE)
S ^TMP("LEXRX",$J,"T",1,"ELAP")=LEXELP
Q
FIX(X) ; Fix Deactivated Expressions in 757.21
N DA,DIK,LEXEXP,LEXDFL Q:'$D(LEXFIX) S DA=+($G(X)) Q:+DA'>0 Q:'$D(^LEX(757.21,+DA,0))
S LEXEXP=+$G(^LEX(757.21,+DA,0)) Q:+LEXEXP'>0
S LEXDFL=$P($G(^LEX(757.01,+LEXEXP,1)),"^",5) Q:+LEXDFL'>0
I $D(LEXFIX) S DIK="^LEX(757.21," D ^DIK
Q
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
CLR ; Clear
N LEXFIX,LEXNAM,LEXQ,LEXSET,LEXTEST,ZTQUEUED,ZTREQ
Q
DEA(X) ; Expression/Concept Deactive
N LEXA,LEXEA,LEXEIEN,LEXMA,LEXMIEN,LEXN S LEXEIEN=+($G(X)),LEXN=$G(^LEX(757.01,+LEXEIEN,1))
S LEXEA=+($P(LEXN,"^",5)),LEXMIEN=+LEXN,LEXN=+($P(LEXN,"^",2)) Q:LEXN=1&(LEXEA>0) 1 Q:LEXN=1&(LEXEA'>0) 0
S LEXMIEN=+($G(^LEX(757,+LEXMIEN,0))),LEXMA=+($P($G(^LEX(757.01,+LEXMIEN,1)),"^",5)) Q:(LEXEA+LEXMA)>0 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXRXF 12792 printed Apr 09, 2024@21:09:32 Page 2
LEXRXF ;ISL/KER - Re-Index 757.21 B/C/AA ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**81,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757) SACC 1.3
+5 ; ^LEX(757.01) SACC 1.3
+6 ; ^LEX(757.011) SACC 1.3
+7 ; ^LEX(757.21) SACC 1.3
+8 ; ^LEXT(757.2) SACC 1.3
+9 ; ^TMP("LEXRX",$J) SACC 2.3.2.5.1
+10 ; ^TMP("LEXRXF",$J) SACC 2.3.2.5.1
+11 ; ^TMP("LEXTKN",$J) SACC 2.3.2.5.1
+12 ; ^TMP("LEXWRD",$J) SACC 2.3.2.5.1
+13 ;
+14 ; External References
+15 ; FILE^DID ICR 2052
+16 ; ^DIK ICR 10013
+17 ; IXALL^DIK ICR 10013
+18 ; $$FMDIFF^XLFDT ICR 10103
+19 ; $$NOW^XLFDT ICR 10103
+20 ; $$UP^XLFSTR ICR 10104
+21 ;
+22 ; Local Variables NEWed or KILLed Elsewhere
+23 ; LEXFIX Fix Index flag NEWed/KILLed by LEXRXXT
+24 ; LEXNAM Task name NEWed/KILLed by LEXRXXT
+25 ; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
+26 ; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
+27 ; LEXTEST Test variable NEWed/KILLed by Developer
+28 ; ZTQUEUED Task flag NEWed/KILLed by Taskman
+29 ; ZTREQ Task Reqest NEWed/KILLed by Taskman
+30 ;
+31 QUIT
EN ; Main Entry Point
R75721 ; Repair file 757.21
+1 KILL ^TMP("LEXRXF",$JOB)
DO RB
DO RC
DO RAA
DO SET
KILL ^TMP("LEXRXF",$JOB)
+2 QUIT
RB ; Index ^LEX(757.21,"B",EXP,IEN)
+1 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
+2 SET LEXFI="757.21"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.21 ""B""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXFI=757.21
SET LEXIDX="B"
SET LEXIDXT="^LEX(757.21,""B"",EXP,IEN)"
+5 FOR
SET LEXSTR=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR))
if '$LENGTH(LEXSTR)
QUIT
Begin DoDot:1
+6 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+7 SET LEXNDS=LEXNDS+1
NEW LEXOK,LEXEX
SET LEXEX=$PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",1)
+8 SET LEXOK=0
if LEXEX=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+9 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
if $LENGTH(LEXEX)
SET ^LEX(LEXFI,LEXIDX,LEXEX,LEXIEN)=""
+10 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+12 NEW DA,DIK,X
SET DA=LEXIEN
SET X=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",1)
if '$LENGTH(X)
QUIT
+13 IF '$DATA(^LEX(LEXFI,LEXIDX,X,DA))
Begin DoDot:2
+14 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",X,?58," ",DA
End DoDot:2
+15 if $LENGTH(X)
SET ^LEX(LEXFI,LEXIDX,X,DA)=""
End DoDot:1
+16 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+17 HANG 1
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+18 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+19 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+20 QUIT
RC ; Index ^LEX(757.21,"C",EXP,IEN)
+1 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
+2 SET LEXFI="757.21"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.21 ""C""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXFI=757.21
SET LEXIDX="C"
SET LEXIDXT="^LEX(757.21,""C"",EXP,IEN)"
+5 FOR
SET LEXSTR=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR))
if '$LENGTH(LEXSTR)
QUIT
Begin DoDot:1
+6 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:2
+7 SET LEXNDS=LEXNDS+1
NEW LEXOK,LEXEX,LEXEXP
+8 SET LEXEX=$PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",1)
+9 SET LEXEXP=$EXTRACT($$UP^XLFSTR($GET(^LEX(757.01,+($GET(LEXEX)),0))),1,63)
+10 SET LEXOK=0
if LEXEXP=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+11 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,"C",LEXSTR,LEXIEN)
if $LENGTH(LEXEXP)
SET ^LEX(LEXFI,"C",LEXEXP,LEXIEN)=""
+12 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,$EXTRACT(LEXSTR,1,28),?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+13 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+14 NEW DA,DIK,X,LEXEXP
SET DA=LEXIEN
SET X=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",1)
SET LEXEXP=$EXTRACT($$UP^XLFSTR(^LEX(757.01,X,0)),1,63)
+15 if +X'>0
QUIT
if '$LENGTH(LEXEXP)
QUIT
+16 IF '$DATA(^LEX(LEXFI,LEXIDX,LEXEXP,DA))
Begin DoDot:2
+17 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",$EXTRACT(LEXEXP,1,20),?58," ",DA
End DoDot:2
+18 SET ^LEX(LEXFI,LEXIDX,LEXEXP,DA)=""
End DoDot:1
+19 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+20 HANG 1
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+21 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+22 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+23 QUIT
RAA ; Index ^LEX(757.21,("A"_SUBSET),WORD,IEN)
+1 ; ^LEX(757.21,"ADEN",WORD,IEN)
+2 ; ^LEX(757.21,"AIMM",WORD,IEN)
+3 ; ^LEX(757.21,"ANUR",WORD,IEN)
+4 ; ^LEX(757.21,"ASOC",WORD,IEN)
+5 ; ^LEX(757.21,[etc],WORD,IEN)
+6 ;
+7 if $DATA(ZTQUEUED)
SET ZTREQ="@"
NEW LEXARY,LEXBEG,LEXCT,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT
+8 NEW LEXIEN,LEXIT,LEXKEY,LEXKEYS,LEXMIS,LEXND,LEXSERR,LEXSIEN,LEXSNDS,LEXSTR,LEXTC,LEXTIM,X
+9 SET LEXFI="757.21"
KILL ^TMP("LEXRXF",$JOB)
if '$LENGTH($GET(LEXNAM))
SET LEXNAM="LEXRXONE"
+10 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.21 ""AA""")
if LEXTC=1
QUIT
+11 SET LEXBEG=$$NOW^XLFDT
SET (LEXSNDS)=0
SET LEXSTR=""
SET LEXFI=757.21
SET LEXIDX=" "
+12 SET LEXFI=757.21
SET (LEXMIS,LEXIT)=0
SET LEXIDX="A"
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
if '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+13 KILL ^TMP("LEXRXF",$JOB,LEXIDX)
if $EXTRACT(LEXIDX,1)'="A"
QUIT
if $LENGTH(LEXIDX)'=4
QUIT
+14 NEW LEXTC,LEXSTR,LEXCT,LEXBEG,LEXEND,LEXTIM,LEXERR,LEXNDS
+15 SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,("Repairing File #757.21 """_LEXIDX_""""))
+16 SET (LEXNDS,LEXERR)=0
SET LEXTIM=""
SET LEXBEG=$$NOW^XLFDT
SET LEXSTR=""
SET LEXCT=0
+17 IF '$DATA(ZTQUEUED)
WRITE !,"^LEX(757.21,""",LEXIDX,""")"
+18 FOR
SET LEXSTR=$ORDER(^LEX(757.21,LEXIDX,LEXSTR))
if '$LENGTH(LEXSTR)
QUIT
Begin DoDot:2
+19 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.21,LEXIDX,LEXSTR,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:3
+20 NEW LEXEXI
SET LEXEXI=+($GET(^LEX(757.21,+LEXIEN,0)))
+21 SET LEXSNDS=+($GET(LEXSNDS))+1
SET LEXNDS=+($GET(LEXNDS))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"N")=LEXNDS
SET LEXCT=LEXCT+1
+22 IF '$DATA(^LEX(757.21,LEXIEN,0))
Begin DoDot:4
+23 SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"E")=LEXERR
+24 if '$DATA(LEXTEST)
KILL ^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)
+25 IF '$DATA(ZTQUEUED)
WRITE !,?8,757.21,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:4
QUIT
+26 NEW LEXKEY,LEXKEYS,LEXDEA,LEXTTYP
SET LEXDEA=$$DEA(+LEXEXI)
if +LEXDEA>0
QUIT
+27 SET LEXTTYP=$PIECE($GET(^LEX(757.01,+LEXEXI,1)),"^",2)
if LEXTTYP=8
QUIT
+28 KILL LEXKEYS
DO KEYS(LEXIEN,.LEXKEYS,LEXIDX)
+29 IF '$DATA(LEXKEYS(LEXSTR))
Begin DoDot:4
+30 SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"E")=LEXERR
+31 if '$DATA(LEXTEST)
KILL ^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)
+32 IF '$DATA(ZTQUEUED)
WRITE !,?8,757.21,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:4
QUIT
+33 SET LEXKEY=""
FOR
SET LEXKEY=$ORDER(LEXKEYS(LEXKEY))
if '$LENGTH(LEXKEY)
QUIT
Begin DoDot:4
+34 NEW LEXND
SET LEXND="^LEX(757.21,"""_LEXIDX_""","""_LEXKEY_""","_+LEXIEN_")"
+35 IF '$DATA(@LEXND)
SET LEXMIS=+($GET(LEXMIS))+1
SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"E")=LEXERR
+36 if '$DATA(LEXTEST)
SET @LEXND=""
+37 if '$DATA(ZTQUEUED)&('$DATA(@LEXND))
WRITE !,$JUSTIFY(LEXCT,6),?15,LEXND
SET @LEXND=""
End DoDot:4
End DoDot:3
End DoDot:2
+38 IF '$DATA(ZTQUEUED)
IF +($GET(LEXCT))>0
Begin DoDot:2
+39 IF +($GET(LEXERR))'>0
WRITE ?22,$JUSTIFY(+($GET(LEXCT)),12)," Tested"
+40 IF +($GET(LEXERR))>0
WRITE !,?22,$JUSTIFY(+($GET(LEXCT)),12),"/",+($GET(LEXERR))," Tested/Errors"
End DoDot:2
+41 HANG 1
SET LEXEND=$$NOW^XLFDT
SET LEXTIM=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+42 if $EXTRACT(LEXTIM,1)=" "&($EXTRACT(LEXTIM,3)="
SET LEXTIM=$TRANSLATE(LEXTIM," ","0")
+43 SET ^TMP("LEXRXF",$JOB,LEXIDX,"T")=LEXTIM
End DoDot:1
if LEXIT>0
QUIT
+44 HANG 1
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+45 ;
+46 NEW LEXSIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.12,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+47 NEW LEXEX,LEXSS,LEXSSN,LEXKEY,LEXKEYS
+48 SET LEXSS=+($PIECE($GET(^LEX(757.21,+LEXSIEN,0)),"^",2))
+49 SET LEXSSN=$PIECE($GET(^LEXT(757.2,+LEXSS,5)),"^",2)
if $LENGTH(LEXSSN)'=3
QUIT
SET LEXSSN="A"_LEXSSN
+50 KILL LEXKEYS
DO KEYS(LEXSIEN,.LEXKEYS,LEXSSN)
+51 SET LEXKEY=""
FOR
SET LEXKEY=$ORDER(LEXKEYS(LEXKEY))
if '$LENGTH(LEXKEY)
QUIT
Begin DoDot:2
+52 SET ^LEX(757.21,LEXSSN,LEXKEY,LEXSIEN)=""
End DoDot:2
End DoDot:1
+53 ;
+54 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+55 SET (LEXSNDS,LEXSERR)=0
SET LEXIDX=" "
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
if '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+56 if $LENGTH(LEXIDX)'>1
QUIT
NEW LEXE,LEXN
SET LEXE=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"E"))
SET LEXSERR=LEXSERR+LEXE
+57 SET LEXN=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"N"))
SET LEXSNDS=LEXSNDS+LEXN
End DoDot:1
+58 DO REP^LEXRXXS(LEXFI,LEXFI,"A***",LEXSNDS,LEXSERR,"^LEX(757.21,""A***"",WORD,IEN)",LEXELP)
+59 SET LEXIDX=" "
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
if '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+60 if $LENGTH(LEXIDX)>1
QUIT
NEW LEXE,LEXN
SET LEXE=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"E"))
SET LEXSERR=LEXSERR+LEXE
+61 SET LEXN=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"N"))
SET LEXSNDS=LEXSNDS+LEXN
End DoDot:1
+62 SET ^TMP("LEXRX",$JOB,"TERR")=+($GET(LEXSERR))
+63 SET LEXIDX=" "
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
if '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+64 if LEXIDX="B"
QUIT
if LEXIDX="C"
QUIT
+65 NEW LEXFI,LEXERR,LEXELP,LEXNDS,LEXIDXT
SET LEXFI=757.21
+66 SET LEXERR=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"E"))
+67 SET LEXNDS=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"N"))
+68 SET LEXELP=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"T"))
+69 SET LEXIDXT="^LEX(757.21,"""_LEXIDX_""",WORD,IEN)"
+70 SET LEXERR=$SELECT(+($GET(LEXERR))>0:LEXERR,1:"")
+71 SET LEXNDS=$SELECT(+($GET(LEXNDS))>0:LEXNDS,1:"")
+72 SET LEXELP=$SELECT($LENGTH($GET(LEXELP))>0:LEXELP,1:"")
+73 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
End DoDot:1
+74 KILL ^TMP("LEXRXF",$JOB)
+75 QUIT
+76 ;
+77 ; Miscellaneous
KEYS(X,LEXARY,LEXIDX) ; Parse Sub-Set Expression into Keywords
+1 NEW LEXSI,LEXEXI,LEXEXP,LEXI,LEXIEN,LEXK,LEXMC,LEXSIEN
KILL LEXARY
+2 SET LEXSI=+($GET(X))
if +LEXSI'>0
QUIT
if '$DATA(^LEX(757.21,+LEXSI,0))
QUIT
+3 SET LEXIDX=$GET(LEXIDX)
if '$LENGTH(LEXIDX)
QUIT
if $LENGTH(LEXIDX)'=4
QUIT
if $EXTRACT(LEXIDX,1)'="A"
QUIT
+4 SET LEXIEN=+($GET(^LEX(757.21,+LEXSI,0)))
if '$DATA(^LEX(757.01,+LEXIEN,0))
QUIT
+5 SET LEXMC=+($GET(^LEX(757.01,LEXIEN,1)))
if LEXMC'>0
QUIT
if '$DATA(^LEX(757,+LEXMC,0))
QUIT
+6 SET LEXEXI=0
FOR
SET LEXEXI=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEXI))
if +LEXEXI'>0
QUIT
Begin DoDot:1
+7 NEW X,LEXEXP,LEXTTYP,LEXDEA,LEXI
SET LEXDEA=$$DEA(+LEXEXI)
if +($GET(LEXDEA))>0
QUIT
+8 SET LEXTTYP=+($PIECE($GET(^LEX(757.01,+LEXEXI,1)),"^",2))
if LEXTTYP=8
QUIT
+9 SET (X,LEXEXP)=$GET(^LEX(757.01,+LEXEXI,0))
KILL ^TMP("LEXTKN",$JOB)
DO PTX^LEXTOKN
+10 SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+11 if $LENGTH($ORDER(^TMP("LEXTKN",$JOB,LEXI,"")))
SET LEXARY($ORDER(^TMP("LEXTKN",$JOB,LEXI,"")))=""
End DoDot:2
+12 IF $DATA(^LEX(757.01,+LEXEXI,5,"B"))
DO SUP(+LEXEXI,.LEXARY)
+13 IF $DATA(^LEX(757.05,"AEXP",+LEXEXI))
DO REP(+LEXEXI,.LEXARY)
End DoDot:1
+14 KILL ^TMP("LEXTKN",$JOB)
+15 QUIT
SUP(X,LEXARY) ; Supplemental Keywords
+1 IF $DATA(^LEX(757.01,+($GET(X)),5,"B"))
Begin DoDot:1
+2 NEW LEXK
SET LEXK=""
FOR
SET LEXK=$ORDER(^LEX(757.01,+($GET(X)),5,"B",LEXK))
if '$LENGTH(LEXK)
QUIT
SET LEXARY(LEXK)=""
End DoDot:1
+3 QUIT
REP(X,LEXARY) ; Repacement/Linked Keywords
+1 NEW LEXEXI,LEXLIEN,LEXSTR
SET LEXEXI=+($GET(X))
SET LEXSTR=""
IF +LEXEXI>0
Begin DoDot:1
+2 SET LEXLIEN=0
FOR
SET LEXLIEN=$ORDER(^LEX(757.05,"AEXP",+LEXEXI,LEXLIEN))
if +LEXLIEN'>0
QUIT
Begin DoDot:2
+3 if '$DATA(^LEX(757.05,+LEXLIEN,1,"B",+LEXEXI))
QUIT
NEW LEXN,LEXT,LEXE,LEXA
+4 SET LEXN=$GET(^LEX(757.05,+LEXLIEN,0))
SET LEXT=$PIECE(LEXN,"^",1)
SET LEXE=$PIECE(LEXN,"^",2)
SET LEXA=$PIECE(LEXN,"^",3)
+5 if LEXA'="L"
QUIT
if $LENGTH(LEXT)
SET LEXARY(LEXT)=""
End DoDot:2
End DoDot:1
+6 QUIT
SET ; Re-Index Subset file 757.21 (Set logic only)
+1 if '$DATA(LEXSET)
QUIT
NEW LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
+2 NEW LEXOUT,LEXMSG
SET LEXFI=757.21
+3 DO FILE^DID(LEXFI,"N","GLOBAL NAME","LEXOUT","LEXMSG")
+4 SET LEXRT=$GET(LEXOUT("GLOBAL NAME"))
if LEXRT'["^LEX"
QUIT
+5 SET LEXPRE=$GET(^TMP("LEXRX",$JOB,"T",1,"ELAP"))
+6 SET LEXBEG=$$NOW^XLFDT
SET LEXNM=$$FN^LEXRXXM(LEXFI)
+7 SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,("Re-Indexing File #"_LEXFI))
+8 if LEXTC=1
QUIT
IF '$DATA(ZTQUEUED)
WRITE !,?8,"Re-Indexing",!
+9 NEW LEXIEN,LEXP1,LEXP2,LEXP3,LEXP4
SET (LEXP3,LEXP4,LEXIEN)=0
+10 SET LEXP1=$PIECE($GET(^LEX(LEXFI,0)),"^",1)
SET LEXP2=$PIECE($GET(^LEX(LEXFI,0)),"^",2)
+11 FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+12 if $DATA(LEXFIX)
DO FIX(LEXIEN)
IF $DATA(^LEX(LEXFI,+LEXIEN,0))
SET LEXP3=LEXIEN
SET LEXP4=LEXP4+1
End DoDot:1
+13 if LEXP3>0
SET $PIECE(^LEX(LEXFI,0),"^",3)=LEXP3
if LEXP4>0
SET $PIECE(^LEX(LEXFI,0),"^",4)=LEXP4
+14 IF +($GET(LEXP4))>0
NEW DIK
SET DIK="^LEX(757.21,"
DO IXALL^DIK
+15 if $DATA(LEXQ)
QUIT
HANG 1
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+16 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+17 DO REP^LEXRXXS(LEXFI,LEXFI,"ALLIX",,,"Re-Index",LEXELP)
+18 SET LEXELP=$$ADDT^LEXRXXM(LEXELP,LEXPRE)
+19 SET ^TMP("LEXRX",$JOB,"T",1,"ELAP")=LEXELP
+20 QUIT
FIX(X) ; Fix Deactivated Expressions in 757.21
+1 NEW DA,DIK,LEXEXP,LEXDFL
if '$DATA(LEXFIX)
QUIT
SET DA=+($GET(X))
if +DA'>0
QUIT
if '$DATA(^LEX(757.21,+DA,0))
QUIT
+2 SET LEXEXP=+$GET(^LEX(757.21,+DA,0))
if +LEXEXP'>0
QUIT
+3 SET LEXDFL=$PIECE($GET(^LEX(757.01,+LEXEXP,1)),"^",5)
if +LEXDFL'>0
QUIT
+4 IF $DATA(LEXFIX)
SET DIK="^LEX(757.21,"
DO ^DIK
+5 QUIT
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
CLR ; Clear
+1 NEW LEXFIX,LEXNAM,LEXQ,LEXSET,LEXTEST,ZTQUEUED,ZTREQ
+2 QUIT
DEA(X) ; Expression/Concept Deactive
+1 NEW LEXA,LEXEA,LEXEIEN,LEXMA,LEXMIEN,LEXN
SET LEXEIEN=+($GET(X))
SET LEXN=$GET(^LEX(757.01,+LEXEIEN,1))
+2 SET LEXEA=+($PIECE(LEXN,"^",5))
SET LEXMIEN=+LEXN
SET LEXN=+($PIECE(LEXN,"^",2))
if LEXN=1&(LEXEA>0)
QUIT 1
if LEXN=1&(LEXEA'>0)
QUIT 0
+3 SET LEXMIEN=+($GET(^LEX(757,+LEXMIEN,0)))
SET LEXMA=+($PIECE($GET(^LEX(757.01,+LEXMIEN,1)),"^",5))
if (LEXEA+LEXMA)>0
QUIT 1
+4 QUIT 0
