LEXRXF ;ISL/KER - Re-Index 757.21 B/C/AA ;04/21/2014
;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX( SACC 1.3
; ^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") SACC 2.3.2.5.1
; ^TMP("LEXRXF") SACC 2.3.2.5.1
; ^TMP("LEXTKN") SACC 2.3.2.5.1
; ^TMP("LEXWRD") SACC 2.3.2.5.1
;
; External References
; $$FMDIFF^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
; FILE^DID ICR 2052
; IX1^DIK ICR 10013
; IX1^DIK ICR 10013
;
; Local Variables NEWed or KILLed Elsewhere
; LEXFIX Fix Index flag NEWed/KILLed by LEXRXXT
; LEXNAM Task name NEWed/KILLed by LEXRXXT
; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
; LEXTEST Test variable NEWed/KILLed by Developer
; ZTQUEUED Task flag 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
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
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)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXEX,LEXEXI,LEXELP,LEXEXP,LEXEXPS,LEXFI,LEXI,LEXID,LEXIDX,LEXIDXT,LEXIEN,LEXJ
N LEXMC,LEXNDS,LEXOK,LEXSIDX,LEXSTR,LEXT,LEXTY,LEXW,LEXDENE,LEXIMME,LEXNURE,LEXSOCE,LEXDENN,LEXIMMN,LEXNURN,LEXSOCN,X
S LEXFI="757.21" K ^TMP("LEXRXF",$J)
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.21 ""AA""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS)=0,LEXSTR="",LEXFI=757.21,LEXIDX=" "
S LEXIDX=" " F S LEXIDX=$O(^LEX(757.21,LEXIDX)) Q:'$L(LEXIDX) D
. Q:LEXIDX="B" Q:LEXIDX="C" Q:LEXIDX?1N.N
. S LEXIDXT="^LEX(757.21,"""_LEXIDX_""",WORD,IEN)"
. N LEXBEG,LEXEND,LEXTIM,LEXERR,LEXNDS,LEXELP
. 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 LEXBEG=$$NOW^XLFDT H 2
. I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
. N LEXTNG,LEXTC S LEXFI="757.21",LEXTNG="Repairing"
. I +($G(LEXFI))>0,$D(ZTQUEUED) D Q:LEXTC=1
. . S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,("Repairing File #757.21 """_LEXIDX_""""))
. 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=+($G(LEXNDS))+1,^TMP("LEXRXF",$J,LEXIDX,"N")=LEXNDS
. . . I '$D(^LEX(757.21,LEXIEN,0)) D Q
. . . . S LEXERR=+($G(LEXERR))+1,^TMP("LEXRXF",$J,LEXIDX,"E")=LEXERR
. . . . K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
. . . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . . N LEXI,LEXIX K LEXEXPS
. . . S LEXEX=+($G(^LEX(757.21,LEXIEN,0)))
. . . S LEXMC=$P(^LEX(757.01,LEXEX,1),U,1)
. . . S LEXID=$P($G(^LEX(757.21,LEXIEN,0)),U,2)
. . . S LEXID=$P(^LEXT(757.2,LEXID,0),U,2) S:$L(LEXID) LEXID="A"_LEXID Q:'$L(LEXID)
. . . S LEXEXI=0 F S LEXEXI=$O(^LEX(757.01,"AMC",LEXMC,LEXEXI)) Q:+LEXEXI'>0 D
. . . . N LEXTY,LEXT,LEXW,LEXJ,LEXEXP,LEXSIDX S LEXEXP=$G(^LEX(757.01,LEXEXI,0))
. . . . S LEXTY=+($P($G(^LEX(757.01,LEXEXI,1)),U,2)) Q:LEXTY'>0
. . . . S LEXT=+($P($G(^LEX(757.011,LEXTY,0)),"^",2)) Q:LEXT=0
. . . . S LEXSIDX=LEXID K ^TMP("LEXTKN",$J) S X=LEXEXP,LEXIX=LEXIDX,LEXIDX="" D PTX^LEXTOKN S LEXIDX=LEXIX
. . . . I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 D
. . . . . N LEXI S LEXI=0 F S LEXI=$O(^TMP("LEXTKN",$J,LEXI)) Q:+LEXI'>0 D
. . . . . . N LEXW S LEXW=$O(^TMP("LEXTKN",$J,LEXI,"")) Q:'$L(LEXW) S LEXEXPS(LEXID,LEXW,LEXIEN)=""
. . . . K ^TMP("LEXTKN",$J)
. . . I $L(LEXIDX),$L(LEXSTR),$L(LEXIEN) D
. . . . I '$D(LEXEXPS(LEXIDX,LEXSTR,LEXIEN)) D
. . . . . 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,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . . . . N LEXW S LEXW="" F S LEXW=$O(LEXEXPS(LEXIDX,LEXW)) Q:'$L(LEXW) D
. . . . . . N LEXI S LEXI=0 F S LEXI=$O(LEXEXPS(LEXIDX,LEXW,LEXI)) Q:+LEXI'>0 D
. . . . . . . S ^LEX(757.21,LEXID,LEXW,LEXI)=""
. . . K LEXEXPS
. 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
I '$D(ZTQUEUED) W !,?8,"Check for missing records"
N LEXIEN,LEXNDS,LEXBEG,LEXEND,LEXELP,LEXMIS
S LEXBEG=$$NOW^XLFDT,LEXNDS=0,LEXMIS=0
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,LEXIX,LEXAIX,LEXERR,LEXEXP,LEXMC,LEXTEXP,LEXW S DA=LEXIEN
. S LEXIX=$P($G(^LEX(LEXFI,DA,0)),"^",2),LEXIX=$P($G(^LEXT(757.2,+LEXIX,0)),"^",2)
. S LEXAIX="A"_LEXIX
. S LEXERR=$G(^TMP("LEXRXF",$J,LEXAIX,"E"))
. K ^TMP("LEXWRD",$J)
. S LEXEXP=+(^LEX(757.21,DA,0)),LEXMC=$P(^LEX(757.01,LEXEXP,1),U,1)
. K ^TMP("LEXTKN",$J),^TMP("LEXWRD",$J)
. S LEXNDS=LEXNDS+1
. S LEXTEXP=0 F S LEXTEXP=$O(^LEX(757.01,"AMC",LEXMC,LEXTEXP)) Q:+LEXTEXP=0 D
. . N X,LEXIDX,LEXYPE,LEXT,LEXJ S X=$G(^LEX(757.01,LEXTEXP,0)),LEXIDX="" Q:'$L(X)
. . S LEXYPE=+($P($G(^LEX(757.01,LEXTEXP,1)),U,2)) Q:LEXYPE'>0
. . S LEXT=+($P($G(^LEX(757.011,LEXYPE,0)),"^",2)) Q:LEXT=0
. . D PTX^LEXTOKN I $D(^TMP("LEXTKN",$J,0)),^TMP("LEXTKN",$J,0)>0 F LEXJ=1:1:^TMP("LEXTKN",$J,0) D
. . . N LEXW S LEXW=$O(^TMP("LEXTKN",$J,LEXJ,"")) S:$L(LEXW) ^TMP("LEXWRD",$J,LEXW)=""
. . K ^TMP("LEXTKN",$J) Q
. S LEXW="" F S LEXW=$O(^TMP("LEXWRD",$J,LEXW)) Q:'$L(LEXW) D
. . I '$D(^LEX(LEXFI,LEXAIX,LEXW,DA)) D
. . . S LEXMIS=LEXMIS+0
. . . S LEXERR=+($G(LEXERR))+1,^TMP("LEXRXF",$J,LEXAIX,"E")=LEXERR
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXAIX,?30,"Missing ",$E(LEXW,1,18),?58," ",DA
. . S:$L(LEXW)&(+DA>0)&($L(LEXAIX))&($L(LEXFI)) ^LEX(LEXFI,LEXAIX,LEXW,DA)=""
. K ^TMP("LEXWRD",$J),^TMP("LEXTKN",$J)
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,"AAAA",LEXNDS,LEXMIS,"^LEX(757.21,""ASUB"",WORD,IEN)",LEXELP)
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
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,LEXP3,LEXP4 S (LEXP3,LEXP4,LEXIEN)=0
F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK S DA=+($G(LEXIEN)) D:$D(LEXFIX) FIX(DA)
. I $D(^LEX(LEXFI,+LEXIEN,0)) D
. . S LEXP3=LEXIEN,LEXP4=LEXP4+1
. . S DA=LEXIEN,DIK=LEXRT D IX1^DIK
Q:$D(LEXQ) 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
CLR ; Clear
N LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
Q
LEXRXF ;ISL/KER - Re-Index 757.21 B/C/AA ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**81,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX( SACC 1.3
+5 ; ^LEX(757) SACC 1.3
+6 ; ^LEX(757.01) SACC 1.3
+7 ; ^LEX(757.011) SACC 1.3
+8 ; ^LEX(757.21) SACC 1.3
+9 ; ^LEXT(757.2) SACC 1.3
+10 ; ^TMP("LEXRX") SACC 2.3.2.5.1
+11 ; ^TMP("LEXRXF") SACC 2.3.2.5.1
+12 ; ^TMP("LEXTKN") SACC 2.3.2.5.1
+13 ; ^TMP("LEXWRD") SACC 2.3.2.5.1
+14 ;
+15 ; External References
+16 ; $$FMDIFF^XLFDT ICR 10103
+17 ; $$NOW^XLFDT ICR 10103
+18 ; $$UP^XLFSTR ICR 10104
+19 ; FILE^DID ICR 2052
+20 ; IX1^DIK ICR 10013
+21 ; IX1^DIK ICR 10013
+22 ;
+23 ; Local Variables NEWed or KILLed Elsewhere
+24 ; LEXFIX Fix Index flag NEWed/KILLed by LEXRXXT
+25 ; LEXNAM Task name NEWed/KILLed by LEXRXXT
+26 ; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
+27 ; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
+28 ; LEXTEST Test variable NEWed/KILLed by Developer
+29 ; ZTQUEUED Task flag 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 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 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 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXEX,LEXEXI,LEXELP,LEXEXP,LEXEXPS,LEXFI,LEXI,LEXID,LEXIDX,LEXIDXT,LEXIEN,LEXJ
+7 NEW LEXMC,LEXNDS,LEXOK,LEXSIDX,LEXSTR,LEXT,LEXTY,LEXW,LEXDENE,LEXIMME,LEXNURE,LEXSOCE,LEXDENN,LEXIMMN,LEXNURN,LEXSOCN,X
+8 SET LEXFI="757.21"
KILL ^TMP("LEXRXF",$JOB)
+9 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.21 ""AA""")
IF LEXTC=1
QUIT
+10 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS)=0
SET LEXSTR=""
SET LEXFI=757.21
SET LEXIDX=" "
+11 SET LEXIDX=" "
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
IF '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+12 IF LEXIDX="B"
QUIT
IF LEXIDX="C"
QUIT
IF LEXIDX?1N.N
QUIT
+13 SET LEXIDXT="^LEX(757.21,"""_LEXIDX_""",WORD,IEN)"
+14 NEW LEXBEG,LEXEND,LEXTIM,LEXERR,LEXNDS,LEXELP
+15 SET LEXERR=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"E"))
+16 SET LEXNDS=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"N"))
+17 SET LEXELP=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"T"))
+18 SET LEXBEG=$$NOW^XLFDT
HANG 2
+19 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+20 NEW LEXTNG,LEXTC
SET LEXFI="757.21"
SET LEXTNG="Repairing"
+21 IF +($GET(LEXFI))>0
IF $DATA(ZTQUEUED)
Begin DoDot:2
+22 SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,("Repairing File #757.21 """_LEXIDX_""""))
End DoDot:2
IF LEXTC=1
QUIT
+23 FOR
SET LEXSTR=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR))
IF '$LENGTH(LEXSTR)
QUIT
Begin DoDot:2
+24 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:3
+25 SET LEXNDS=+($GET(LEXNDS))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"N")=LEXNDS
+26 IF '$DATA(^LEX(757.21,LEXIEN,0))
Begin DoDot:4
+27 SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"E")=LEXERR
+28 IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
+29 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:4
QUIT
+30 NEW LEXI,LEXIX
KILL LEXEXPS
+31 SET LEXEX=+($GET(^LEX(757.21,LEXIEN,0)))
+32 SET LEXMC=$PIECE(^LEX(757.01,LEXEX,1),U,1)
+33 SET LEXID=$PIECE($GET(^LEX(757.21,LEXIEN,0)),U,2)
+34 SET LEXID=$PIECE(^LEXT(757.2,LEXID,0),U,2)
IF $LENGTH(LEXID)
SET LEXID="A"_LEXID
IF '$LENGTH(LEXID)
QUIT
+35 SET LEXEXI=0
FOR
SET LEXEXI=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXEXI))
IF +LEXEXI'>0
QUIT
Begin DoDot:4
+36 NEW LEXTY,LEXT,LEXW,LEXJ,LEXEXP,LEXSIDX
SET LEXEXP=$GET(^LEX(757.01,LEXEXI,0))
+37 SET LEXTY=+($PIECE($GET(^LEX(757.01,LEXEXI,1)),U,2))
IF LEXTY'>0
QUIT
+38 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXTY,0)),"^",2))
IF LEXT=0
QUIT
+39 SET LEXSIDX=LEXID
KILL ^TMP("LEXTKN",$JOB)
SET X=LEXEXP
SET LEXIX=LEXIDX
SET LEXIDX=""
DO PTX^LEXTOKN
SET LEXIDX=LEXIX
+40 IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
Begin DoDot:5
+41 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXTKN",$JOB,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:6
+42 NEW LEXW
SET LEXW=$ORDER(^TMP("LEXTKN",$JOB,LEXI,""))
IF '$LENGTH(LEXW)
QUIT
SET LEXEXPS(LEXID,LEXW,LEXIEN)=""
End DoDot:6
End DoDot:5
+43 KILL ^TMP("LEXTKN",$JOB)
End DoDot:4
+44 IF $LENGTH(LEXIDX)
IF $LENGTH(LEXSTR)
IF $LENGTH(LEXIEN)
Begin DoDot:4
+45 IF '$DATA(LEXEXPS(LEXIDX,LEXSTR,LEXIEN))
Begin DoDot:5
+46 SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXIDX,"E")=LEXERR
+47 IF '$DATA(LEXTEST)
KILL ^LEX(757.21,LEXIDX,LEXSTR,LEXIEN)
+48 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
+49 NEW LEXW
SET LEXW=""
FOR
SET LEXW=$ORDER(LEXEXPS(LEXIDX,LEXW))
IF '$LENGTH(LEXW)
QUIT
Begin DoDot:6
+50 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXEXPS(LEXIDX,LEXW,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:7
+51 SET ^LEX(757.21,LEXID,LEXW,LEXI)=""
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
+52 KILL LEXEXPS
End DoDot:3
End DoDot:2
+53 SET LEXEND=$$NOW^XLFDT
SET LEXTIM=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+54 IF $EXTRACT(LEXTIM,1)=" "&($EXTRACT(LEXTIM,3)="
SET LEXTIM=$TRANSLATE(LEXTIM," ","0")
+55 SET ^TMP("LEXRXF",$JOB,LEXIDX,"T")=LEXTIM
End DoDot:1
+56 IF '$DATA(ZTQUEUED)
WRITE !,?8,"Check for missing records"
+57 NEW LEXIEN,LEXNDS,LEXBEG,LEXEND,LEXELP,LEXMIS
+58 SET LEXBEG=$$NOW^XLFDT
SET LEXNDS=0
SET LEXMIS=0
+59 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:1
+60 NEW DA,LEXIX,LEXAIX,LEXERR,LEXEXP,LEXMC,LEXTEXP,LEXW
SET DA=LEXIEN
+61 SET LEXIX=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",2)
SET LEXIX=$PIECE($GET(^LEXT(757.2,+LEXIX,0)),"^",2)
+62 SET LEXAIX="A"_LEXIX
+63 SET LEXERR=$GET(^TMP("LEXRXF",$JOB,LEXAIX,"E"))
+64 KILL ^TMP("LEXWRD",$JOB)
+65 SET LEXEXP=+(^LEX(757.21,DA,0))
SET LEXMC=$PIECE(^LEX(757.01,LEXEXP,1),U,1)
+66 KILL ^TMP("LEXTKN",$JOB),^TMP("LEXWRD",$JOB)
+67 SET LEXNDS=LEXNDS+1
+68 SET LEXTEXP=0
FOR
SET LEXTEXP=$ORDER(^LEX(757.01,"AMC",LEXMC,LEXTEXP))
IF +LEXTEXP=0
QUIT
Begin DoDot:2
+69 NEW X,LEXIDX,LEXYPE,LEXT,LEXJ
SET X=$GET(^LEX(757.01,LEXTEXP,0))
SET LEXIDX=""
IF '$LENGTH(X)
QUIT
+70 SET LEXYPE=+($PIECE($GET(^LEX(757.01,LEXTEXP,1)),U,2))
IF LEXYPE'>0
QUIT
+71 SET LEXT=+($PIECE($GET(^LEX(757.011,LEXYPE,0)),"^",2))
IF LEXT=0
QUIT
+72 DO PTX^LEXTOKN
IF $DATA(^TMP("LEXTKN",$JOB,0))
IF ^TMP("LEXTKN",$JOB,0)>0
FOR LEXJ=1:1:^TMP("LEXTKN",$JOB,0)
Begin DoDot:3
+73 NEW LEXW
SET LEXW=$ORDER(^TMP("LEXTKN",$JOB,LEXJ,""))
IF $LENGTH(LEXW)
SET ^TMP("LEXWRD",$JOB,LEXW)=""
End DoDot:3
+74 KILL ^TMP("LEXTKN",$JOB)
QUIT
End DoDot:2
+75 SET LEXW=""
FOR
SET LEXW=$ORDER(^TMP("LEXWRD",$JOB,LEXW))
IF '$LENGTH(LEXW)
QUIT
Begin DoDot:2
+76 IF '$DATA(^LEX(LEXFI,LEXAIX,LEXW,DA))
Begin DoDot:3
+77 SET LEXMIS=LEXMIS+0
+78 SET LEXERR=+($GET(LEXERR))+1
SET ^TMP("LEXRXF",$JOB,LEXAIX,"E")=LEXERR
+79 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXAIX,?30,"Missing ",$EXTRACT(LEXW,1,18),?58," ",DA
End DoDot:3
+80 IF $LENGTH(LEXW)&(+DA>0)&($LENGTH(LEXAIX))&($LENGTH(LEXFI))
SET ^LEX(LEXFI,LEXAIX,LEXW,DA)=""
End DoDot:2
+81 KILL ^TMP("LEXWRD",$JOB),^TMP("LEXTKN",$JOB)
End DoDot:1
+82 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+83 IF $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+84 DO REP^LEXRXXS(LEXFI,LEXFI,"AAAA",LEXNDS,LEXMIS,"^LEX(757.21,""ASUB"",WORD,IEN)",LEXELP)
+85 SET LEXIDX=" "
FOR
SET LEXIDX=$ORDER(^LEX(757.21,LEXIDX))
IF '$LENGTH(LEXIDX)
QUIT
Begin DoDot:1
+86 IF LEXIDX="B"
QUIT
IF LEXIDX="C"
QUIT
+87 NEW LEXFI,LEXERR,LEXELP,LEXNDS,LEXIDXT
SET LEXFI=757.21
+88 SET LEXERR=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"E"))
+89 SET LEXNDS=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"N"))
+90 SET LEXELP=$GET(^TMP("LEXRXF",$JOB,LEXIDX,"T"))
+91 SET LEXIDXT="^LEX(757.21,"""_LEXIDX_""",WORD,IEN)"
+92 SET LEXERR=$SELECT(+($GET(LEXERR))>0:LEXERR,1:"")
+93 SET LEXNDS=$SELECT(+($GET(LEXNDS))>0:LEXNDS,1:"")
+94 SET LEXELP=$SELECT($LENGTH($GET(LEXELP))>0:LEXELP,1:"")
+95 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
End DoDot:1
+96 KILL ^TMP("LEXRXF",$JOB)
+97 QUIT
+98 ;
+99 ; Miscellaneous
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,LEXP3,LEXP4
SET (LEXP3,LEXP4,LEXIEN)=0
+10 FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
IF +LEXIEN'>0
QUIT
Begin DoDot:1
+11 NEW DA,DIK
SET DA=+($GET(LEXIEN))
IF $DATA(LEXFIX)
DO FIX(DA)
+12 IF $DATA(^LEX(LEXFI,+LEXIEN,0))
Begin DoDot:2
+13 SET LEXP3=LEXIEN
SET LEXP4=LEXP4+1
+14 SET DA=LEXIEN
SET DIK=LEXRT
DO IX1^DIK
End DoDot:2
End DoDot:1
+15 IF $DATA(LEXQ)
QUIT
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
CLR ; Clear
+1 NEW LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
+2 QUIT
