LEXRXC2 ;ISL/KER - Re-Index 757.01 AMC/APAR ;05/23/2017
;;2.0;LEXICON UTILITY;**81,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX( SACC 1.3
; ^LEX(757.01, SACC 1.3
; ^LEX(757.04, SACC 1.3
; ^LEX(757.05, SACC 1.3
;
; External References
; ^DIK ICR 10013
; IX1^DIK ICR 10013
; $$FMDIFF^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXNAM Task name NEWed/KILLed by LEXRXXT
; LEXTEST Test variable NEWed/KILLed by Developer
; ZTQUEUED Task flag NEWed/KILLed by Taskman
;
Q
; NOTES:
;
; The AMC cross-references is used to create the AWRD
; cross-reference, hence the AMC cross-reference must
; be repaired/re-indexed before AWRD.
;
EN ; Main Entry Point
R75701 ; Repair file 757.01
D RAMC,RAPAR
Q
RAMC ; Index ^LEX(757.01,"AMC",MC,IEN)
S:$D(ZTQUEUED) ZTREQ="@" N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
S LEXFI="757.01"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.01 ""AMC""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXFI=757.01,LEXIDX="AMC",LEXIDXT="^LEX(757.01,""AMC"",MC,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
. . I '$D(^LEX(LEXFI,LEXIEN,0)) D Q
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
. . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
. . N LEXOK,LEXMC S LEXMC=+($P($G(^LEX(LEXFI,LEXIEN,1)),"^",1))
. . S LEXOK=0 S:LEXMC=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN) S:+LEXMC>0 ^LEX(LEXFI,LEXIDX,+LEXMC,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=+($G(^LEX(LEXFI,DA,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",?58," ",DA
. S:$L(X) ^LEX(LEXFI,LEXIDX,X,DA)=""
. S ^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
RAPAR ; Index ^LEX(757.01,"APAR",MC,IEN)
S:$D(ZTQUEUED) ZTREQ="@" Q N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXNDS,LEXOK,LEXPAR,LEXPR,LEXSTR
S LEXFI="757.01"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.01 ""APAR""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXFI=757.01,LEXIDX="APAR",LEXIDXT="^LEX(757.01,""APAR"",PARENT,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,LEXPR S LEXPR=+($P($G(^LEX(LEXFI,LEXIEN,1)),"^",9))
. . S LEXOK=0 S:LEXPR=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN) S:+LEXPR>0 ^LEX(LEXFI,LEXIDX,+LEXPR,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,LEXPAR S DA=LEXIEN S LEXPAR=$P($G(^LEX(757.01,DA,1)),"^",9) Q:'$L(LEXPAR)
. I '$D(^LEX(757.01,LEXIDX,$E(LEXPAR,1,30),DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
. S:$L(LEXPAR) ^LEX(757.01,LEXIDX,$E(LEXPAR,1,30),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
RAWRD ; Index ^LEX(757.01,"AWRD",WORD,MC,EXP)
S:$D(ZTQUEUED) ZTREQ="@" N DA,DIK,LEXBEG,LEXDIF,LEXE,LEXELP,LEXEND,LEXERR,LEXEXCL,LEXEXP,LEXFI,LEXHI,LEXI,LEXIDX,LEXIDXT,LEXL,LEXLO,LEXM
N LEXMCE,LEXNDS,LEXS,LEXS1,LEXS2,LEXS3,LEXS4,LEXSTR,LEXT,LEXTC,LEXTK,LEXTKN,LEXTNG,LEXW,LEXWDS,X
S LEXFI="757.01"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.01 ""AWRD""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXFI=757.01,LEXIDX="AWRD",LEXIDXT="^LEX(757.01,""AWRD"",WORD,MC,EXP)"
S LEXTKN="" F S LEXTKN=$O(^LEX(LEXFI,LEXIDX,LEXTKN)) Q:'$L(LEXTKN) D
. S LEXEXCL=0 I $O(^LEX(757.04,"B",LEXTKN,0))>0 D
. . S LEXEXCL=$P($G(^LEX(757.04,+($O(^LEX(757.04,"B",LEXTKN,0))),0)),"^",2),LEXEXCL=$S(LEXEXCL="B":1,LEXEXCL="I":1,1:0)
. S LEXS1="" F S LEXS1=$O(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1)) Q:'$L(LEXS1) D
. . S LEXS2="" F S LEXS2=$O(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2)) Q:'$L(LEXS2) D
. . . ; Supplemental ^LEX(757.01,"AWRD",WORD,IEN,MC,SUP)
. . . ; Duplicates
. . . N LEXLO,LEXHI F D Q:+($G(LEXHI))'>+($G(LEXLO))
. . . . N DA,DIK S LEXLO=$O(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,"")),LEXHI=$O(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2," "),-1) Q:(+LEXLO+LEXHI)'>0
. . . . I LEXLO>0,LEXHI>0,LEXHI>LEXLO S DA(1)=LEXS1,DA=LEXHI S DIK="^LEX(757.01,"_DA(1)_",5," D:$D(@(DIK_DA_",0)")) ^DIK
. . . I $D(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=10!($D(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=11) D
. . . . N LEXS3 S LEXS3="" F S LEXS3=$O(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3)) Q:'$L(LEXS3) D
. . . . . N LEXEXP,LEXMCE,LEXSTR S LEXNDS=+($G(LEXNDS))+1
. . . . . S LEXEXP=LEXS1,LEXMCE=+($$MCE^LEXRXXM(LEXEXP))
. . . . . S LEXSTR=$P($G(^LEX(LEXFI,+LEXEXP,5,+LEXS3,0)),"^",1)
. . . . . ; Redundant
. . . . . I $D(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=11 D
. . . . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"1",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2,"/",LEXS3
. . . . . . I '$D(LEXTEST) D
. . . . . . . N DA,DIK,LEXI,LEXIDX,LEXT,LEXWDS
. . . . . . . S LEXT=$P($G(^LEX(757.01,+LEXEXP,0)),"^",1),LEXI=0 D WORDS^LEXRXXP(LEXT,.LEXWDS) S LEXIDX="AWRD"
. . . . . . . Q:'$D(LEXWDS(LEXTKN)) S DA(1)=LEXEXP,DA=LEXS3,DIK="^LEX(757.01,"_DA(1)_",5," I $D(@(DIK_DA_",0)")) D
. . . . . . . . D ^DIK K ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3)
. . . . . ; Verify
. . . . . N LEXS D SUP^LEXRXXP(LEXEXP,.LEXS) I '$D(LEXS("S",LEXTKN,LEXS1,LEXS2,LEXS3)) D
. . . . . . Q:+LEXS3'>0 S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"2",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2,"/",LEXS3
. . . . . . I '$D(LEXTEST) K ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3)
. . . ; Linked ^LEX(757.01,"AWRD",WORD,IEN,"LINKED")
. . . I $D(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=1,LEXS2="LINKED" D Q
. . . . N LEXEXP,LEXL S LEXEXP=LEXS1,LEXNDS=+($G(LEXNDS))+1 D LINK^LEXRXXP(LEXEXP,.LEXL)
. . . . Q:$D(LEXL("R",LEXTKN,+LEXEXP,"LINKED"))!($D(LEXL("L",LEXTKN,+LEXEXP,"LINKED")))
. . . . I '$D(LEXL("R",LEXTKN,+LEXEXP,"LINKED"))&($D(LEXL("L",LEXTKN,+LEXEXP,"LINKED"))) D
. . . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"3",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2
. . . . . I '$D(LEXTEST) K ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2)
. . . ; Words ^LEX(757.01,"AWRD",WORD,MC,IEN)
. . . I $D(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=1,+LEXS2>0,$D(^LEX(757.01,+LEXS2,0)) D Q
. . . . N LEXW,LEXIDX D AWRD^LEXRXXP(+LEXS2,.LEXW,1) S LEXIDX="AWRD" S LEXNDS=+($G(LEXNDS))+1
. . . . I '$D(LEXW("W",LEXTKN,LEXS1,LEXS2)) D Q
. . . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"4",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS2
. . . . . I '$D(LEXTEST) K ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2)
S LEXEXP=0 F S LEXEXP=$O(^LEX(LEXFI,LEXEXP)) Q:+LEXEXP'>0 D
. N DA,DIK,LEXS,LEXS1,LEXS1,LEXS3,LEXS4,X S DA=$G(LEXEXP),X=$P($G(^LEX(LEXFI,DA,0)),"^",1) Q:'$L(X)
. I $L(X),$D(^LEX(LEXFI,+($G(DA)),0)),$D(^LEX(LEXFI,+($G(DA)),1)) D
. . N LEXW,LEXTK,LEXM,LEXE S ^LEX(LEXFI,"B",$$UP^XLFSTR($E(X,1,63)),DA)=""
. . D AWRD^LEXRXXP(+DA,.LEXW,1) S LEXTK="" F S LEXTK=$O(LEXW("W",LEXTK)) Q:'$L(LEXTK) D
. . . S LEXM=0 F S LEXM=$O(LEXW("W",LEXTK,LEXM)) Q:+LEXM'>0 D
. . . . S LEXE=0 F S LEXE=$O(LEXW("W",LEXTK,LEXM,LEXE)) Q:+LEXE'>0 D
. . . . . Q:$D(^LEX(757.01,"AWRD",LEXTK,LEXM))
. . . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"5",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$E(LEXTK,1,18),?58," ",LEXM,"/",LEXE
. . . . . S ^LEX(757.01,"AWRD",LEXTK,LEXM,LEXE)=""
. K LEXS D SUP^LEXRXXP(LEXEXP,.LEXS)
. S LEXS1="" F S LEXS1=$O(LEXS("S",LEXS1)) Q:'$L(LEXS1) S LEXS2="" F S LEXS2=$O(LEXS("S",LEXS1,LEXS2)) Q:'$L(LEXS2) D
. . S LEXS3="" F S LEXS3=$O(LEXS("S",LEXS1,LEXS2,LEXS3)) Q:'$L(LEXS3) S LEXS4="" F S LEXS4=$O(LEXS("S",LEXS1,LEXS2,LEXS3,LEXS4)) Q:'$L(LEXS4) D
. . . I '$D(^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3,LEXS4)) D
. . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"6",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$E(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3,"/",LEXS4
. . . . S ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3,LEXS4)=""
. K LEXS D LINK^LEXRXXP(LEXEXP,.LEXS)
. S LEXS1="" F S LEXS1=$O(LEXS("L",LEXS1)) Q:'$L(LEXS1) S LEXS2="" F S LEXS2=$O(LEXS("L",LEXS1,LEXS2)) Q:'$L(LEXS2) D
. . S LEXS3="" F S LEXS3=$O(LEXS("L",LEXS1,LEXS2,LEXS3)) Q:'$L(LEXS3) D
. . . I '$D(^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3)) D
. . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"7",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$E(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3
. . . . S ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3)=""
. S LEXS1="" F S LEXS1=$O(LEXS("R",LEXS1)) Q:'$L(LEXS1) S LEXS2="" F S LEXS2=$O(LEXS("R",LEXS1,LEXS2)) Q:'$L(LEXS2) D
. . S LEXS3="" F S LEXS3=$O(LEXS("R",LEXS1,LEXS2,LEXS3)) Q:'$L(LEXS3) D
. . . I '$D(^LEX(757.01,"AWRD",LEXS1,LEXS2)) D
. . . . Q:$D(^LEX(757.04,"ACTION",LEXS1,"B"))!($D(^LEX(757.04,"ACTION",LEXS1,"I")))
. . . . S LEXERR=+($G(LEXERR))+1 I '$D(ZTQUEUED) W !,"8",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$E(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3
. . . . S ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3)=""
. K LEXS S LEXS=0 F S LEXS=$O(^LEX(LEXFI,LEXEXP,5,LEXS)) Q:+LEXS'>0 D
. . N DA,DIK S DA(1)=LEXEXP,DA=LEXS,DIK="^LEX(757.01,"_DA(1)_",5," D IX1^DIK
S LEXEXP=0 F S LEXEXP=$O(^LEX(757.05,LEXEXP)) Q:+LEXEXP'>0 D
. N DA,DIK S DA=LEXEXP,DIK="^LEX(757.05," D IX1^DIK
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
;
; Miscellaneous
CLR ; Clear
K LEXNAM,LEXTEST,ZTQUEUED
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXRXC2 11075 printed Dec 13, 2024@02:09:13 Page 2
LEXRXC2 ;ISL/KER - Re-Index 757.01 AMC/APAR ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**81,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX( SACC 1.3
+5 ; ^LEX(757.01, SACC 1.3
+6 ; ^LEX(757.04, SACC 1.3
+7 ; ^LEX(757.05, SACC 1.3
+8 ;
+9 ; External References
+10 ; ^DIK ICR 10013
+11 ; IX1^DIK ICR 10013
+12 ; $$FMDIFF^XLFDT ICR 10103
+13 ; $$NOW^XLFDT ICR 10103
+14 ; $$UP^XLFSTR ICR 10104
+15 ;
+16 ; Local Variables NEWed or KILLed Elsewhere
+17 ; LEXNAM Task name NEWed/KILLed by LEXRXXT
+18 ; LEXTEST Test variable NEWed/KILLed by Developer
+19 ; ZTQUEUED Task flag NEWed/KILLed by Taskman
+20 ;
+21 QUIT
+22 ; NOTES:
+23 ;
+24 ; The AMC cross-references is used to create the AWRD
+25 ; cross-reference, hence the AMC cross-reference must
+26 ; be repaired/re-indexed before AWRD.
+27 ;
EN ; Main Entry Point
R75701 ; Repair file 757.01
+1 DO RAMC
DO RAPAR
+2 QUIT
RAMC ; Index ^LEX(757.01,"AMC",MC,IEN)
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
+2 SET LEXFI="757.01"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.01 ""AMC""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXFI=757.01
SET LEXIDX="AMC"
SET LEXIDXT="^LEX(757.01,""AMC"",MC,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
+8 IF '$DATA(^LEX(LEXFI,LEXIEN,0))
Begin DoDot:3
+9 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
+10 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
QUIT
+11 NEW LEXOK,LEXMC
SET LEXMC=+($PIECE($GET(^LEX(LEXFI,LEXIEN,1)),"^",1))
+12 SET LEXOK=0
if LEXMC=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+13 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
if +LEXMC>0
SET ^LEX(LEXFI,LEXIDX,+LEXMC,LEXIEN)=""
+14 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+16 NEW DA,DIK,X
SET DA=LEXIEN
SET X=+($GET(^LEX(LEXFI,DA,1)))
if '$LENGTH(X)
QUIT
+17 IF '$DATA(^LEX(LEXFI,LEXIDX,X,DA))
Begin DoDot:2
+18 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
End DoDot:2
+19 if $LENGTH(X)
SET ^LEX(LEXFI,LEXIDX,X,DA)=""
+20 SET ^LEX(LEXFI,LEXIDX,X,DA)=""
End DoDot:1
+21 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+22 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+23 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+24 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+25 QUIT
RAPAR ; Index ^LEX(757.01,"APAR",MC,IEN)
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXNDS,LEXOK,LEXPAR,LEXPR,LEXSTR
+2 SET LEXFI="757.01"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.01 ""APAR""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXFI=757.01
SET LEXIDX="APAR"
SET LEXIDXT="^LEX(757.01,""APAR"",PARENT,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,LEXPR
SET LEXPR=+($PIECE($GET(^LEX(LEXFI,LEXIEN,1)),"^",9))
+8 SET LEXOK=0
if LEXPR=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+9 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
if +LEXPR>0
SET ^LEX(LEXFI,LEXIDX,+LEXPR,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,LEXPAR
SET DA=LEXIEN
SET LEXPAR=$PIECE($GET(^LEX(757.01,DA,1)),"^",9)
if '$LENGTH(LEXPAR)
QUIT
+13 IF '$DATA(^LEX(757.01,LEXIDX,$EXTRACT(LEXPAR,1,30),DA))
Begin DoDot:2
+14 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing",?58," ",DA
End DoDot:2
+15 if $LENGTH(LEXPAR)
SET ^LEX(757.01,LEXIDX,$EXTRACT(LEXPAR,1,30),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
RAWRD ; Index ^LEX(757.01,"AWRD",WORD,MC,EXP)
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
NEW DA,DIK,LEXBEG,LEXDIF,LEXE,LEXELP,LEXEND,LEXERR,LEXEXCL,LEXEXP,LEXFI,LEXHI,LEXI,LEXIDX,LEXIDXT,LEXL,LEXLO,LEXM
+2 NEW LEXMCE,LEXNDS,LEXS,LEXS1,LEXS2,LEXS3,LEXS4,LEXSTR,LEXT,LEXTC,LEXTK,LEXTKN,LEXTNG,LEXW,LEXWDS,X
+3 SET LEXFI="757.01"
+4 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.01 ""AWRD""")
if LEXTC=1
QUIT
+5 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXFI=757.01
SET LEXIDX="AWRD"
SET LEXIDXT="^LEX(757.01,""AWRD"",WORD,MC,EXP)"
+6 SET LEXTKN=""
FOR
SET LEXTKN=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN))
if '$LENGTH(LEXTKN)
QUIT
Begin DoDot:1
+7 SET LEXEXCL=0
IF $ORDER(^LEX(757.04,"B",LEXTKN,0))>0
Begin DoDot:2
+8 SET LEXEXCL=$PIECE($GET(^LEX(757.04,+($ORDER(^LEX(757.04,"B",LEXTKN,0))),0)),"^",2)
SET LEXEXCL=$SELECT(LEXEXCL="B":1,LEXEXCL="I":1,1:0)
End DoDot:2
+9 SET LEXS1=""
FOR
SET LEXS1=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1))
if '$LENGTH(LEXS1)
QUIT
Begin DoDot:2
+10 SET LEXS2=""
FOR
SET LEXS2=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))
if '$LENGTH(LEXS2)
QUIT
Begin DoDot:3
+11 ; Supplemental ^LEX(757.01,"AWRD",WORD,IEN,MC,SUP)
+12 ; Duplicates
+13 NEW LEXLO,LEXHI
FOR
Begin DoDot:4
+14 NEW DA,DIK
SET LEXLO=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,""))
SET LEXHI=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2," "),-1)
if (+LEXLO+LEXHI)'>0
QUIT
+15 IF LEXLO>0
IF LEXHI>0
IF LEXHI>LEXLO
SET DA(1)=LEXS1
SET DA=LEXHI
SET DIK="^LEX(757.01,"_DA(1)_",5,"
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
End DoDot:4
if +($GET(LEXHI))'>+($GET(LEXLO))
QUIT
+16 IF $DATA(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=10!($DATA(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=11)
Begin DoDot:4
+17 NEW LEXS3
SET LEXS3=""
FOR
SET LEXS3=$ORDER(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3))
if '$LENGTH(LEXS3)
QUIT
Begin DoDot:5
+18 NEW LEXEXP,LEXMCE,LEXSTR
SET LEXNDS=+($GET(LEXNDS))+1
+19 SET LEXEXP=LEXS1
SET LEXMCE=+($$MCE^LEXRXXM(LEXEXP))
+20 SET LEXSTR=$PIECE($GET(^LEX(LEXFI,+LEXEXP,5,+LEXS3,0)),"^",1)
+21 ; Redundant
+22 IF $DATA(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=11
Begin DoDot:6
+23 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"1",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2,"/",LEXS3
+24 IF '$DATA(LEXTEST)
Begin DoDot:7
+25 NEW DA,DIK,LEXI,LEXIDX,LEXT,LEXWDS
+26 SET LEXT=$PIECE($GET(^LEX(757.01,+LEXEXP,0)),"^",1)
SET LEXI=0
DO WORDS^LEXRXXP(LEXT,.LEXWDS)
SET LEXIDX="AWRD"
+27 if '$DATA(LEXWDS(LEXTKN))
QUIT
SET DA(1)=LEXEXP
SET DA=LEXS3
SET DIK="^LEX(757.01,"_DA(1)_",5,"
IF $DATA(@(DIK_DA_",0)"))
Begin DoDot:8
+28 DO ^DIK
KILL ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3)
End DoDot:8
End DoDot:7
End DoDot:6
+29 ; Verify
+30 NEW LEXS
DO SUP^LEXRXXP(LEXEXP,.LEXS)
IF '$DATA(LEXS("S",LEXTKN,LEXS1,LEXS2,LEXS3))
Begin DoDot:6
+31 if +LEXS3'>0
QUIT
SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"2",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2,"/",LEXS3
+32 IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2,LEXS3)
End DoDot:6
End DoDot:5
End DoDot:4
+33 ; Linked ^LEX(757.01,"AWRD",WORD,IEN,"LINKED")
+34 IF $DATA(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=1
IF LEXS2="LINKED"
Begin DoDot:4
+35 NEW LEXEXP,LEXL
SET LEXEXP=LEXS1
SET LEXNDS=+($GET(LEXNDS))+1
DO LINK^LEXRXXP(LEXEXP,.LEXL)
+36 if $DATA(LEXL("R",LEXTKN,+LEXEXP,"LINKED"))!($DATA(LEXL("L",LEXTKN,+LEXEXP,"LINKED")))
QUIT
+37 IF '$DATA(LEXL("R",LEXTKN,+LEXEXP,"LINKED"))&($DATA(LEXL("L",LEXTKN,+LEXEXP,"LINKED")))
Begin DoDot:5
+38 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"3",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS1,"/",LEXS2
+39 IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2)
End DoDot:5
End DoDot:4
QUIT
+40 ; Words ^LEX(757.01,"AWRD",WORD,MC,IEN)
+41 IF $DATA(^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2))=1
IF +LEXS2>0
IF $DATA(^LEX(757.01,+LEXS2,0))
Begin DoDot:4
+42 NEW LEXW,LEXIDX
DO AWRD^LEXRXXP(+LEXS2,.LEXW,1)
SET LEXIDX="AWRD"
SET LEXNDS=+($GET(LEXNDS))+1
+43 IF '$DATA(LEXW("W",LEXTKN,LEXS1,LEXS2))
Begin DoDot:5
+44 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"4",?8,LEXFI,?19,LEXIDX,?30,LEXTKN,?58," ",LEXS2
+45 IF '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXTKN,LEXS1,LEXS2)
End DoDot:5
QUIT
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+46 SET LEXEXP=0
FOR
SET LEXEXP=$ORDER(^LEX(LEXFI,LEXEXP))
if +LEXEXP'>0
QUIT
Begin DoDot:1
+47 NEW DA,DIK,LEXS,LEXS1,LEXS1,LEXS3,LEXS4,X
SET DA=$GET(LEXEXP)
SET X=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",1)
if '$LENGTH(X)
QUIT
+48 IF $LENGTH(X)
IF $DATA(^LEX(LEXFI,+($GET(DA)),0))
IF $DATA(^LEX(LEXFI,+($GET(DA)),1))
Begin DoDot:2
+49 NEW LEXW,LEXTK,LEXM,LEXE
SET ^LEX(LEXFI,"B",$$UP^XLFSTR($EXTRACT(X,1,63)),DA)=""
+50 DO AWRD^LEXRXXP(+DA,.LEXW,1)
SET LEXTK=""
FOR
SET LEXTK=$ORDER(LEXW("W",LEXTK))
if '$LENGTH(LEXTK)
QUIT
Begin DoDot:3
+51 SET LEXM=0
FOR
SET LEXM=$ORDER(LEXW("W",LEXTK,LEXM))
if +LEXM'>0
QUIT
Begin DoDot:4
+52 SET LEXE=0
FOR
SET LEXE=$ORDER(LEXW("W",LEXTK,LEXM,LEXE))
if +LEXE'>0
QUIT
Begin DoDot:5
+53 if $DATA(^LEX(757.01,"AWRD",LEXTK,LEXM))
QUIT
+54 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"5",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$EXTRACT(LEXTK,1,18),?58," ",LEXM,"/",LEXE
+55 SET ^LEX(757.01,"AWRD",LEXTK,LEXM,LEXE)=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+56 KILL LEXS
DO SUP^LEXRXXP(LEXEXP,.LEXS)
+57 SET LEXS1=""
FOR
SET LEXS1=$ORDER(LEXS("S",LEXS1))
if '$LENGTH(LEXS1)
QUIT
SET LEXS2=""
FOR
SET LEXS2=$ORDER(LEXS("S",LEXS1,LEXS2))
if '$LENGTH(LEXS2)
QUIT
Begin DoDot:2
+58 SET LEXS3=""
FOR
SET LEXS3=$ORDER(LEXS("S",LEXS1,LEXS2,LEXS3))
if '$LENGTH(LEXS3)
QUIT
SET LEXS4=""
FOR
SET LEXS4=$ORDER(LEXS("S",LEXS1,LEXS2,LEXS3,LEXS4))
if '$LENGTH(LEXS4)
QUIT
Begin DoDot:3
+59 IF '$DATA(^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3,LEXS4))
Begin DoDot:4
+60 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"6",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$EXTRACT(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3,"/",LEXS4
+61 SET ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3,LEXS4)=""
End DoDot:4
End DoDot:3
End DoDot:2
+62 KILL LEXS
DO LINK^LEXRXXP(LEXEXP,.LEXS)
+63 SET LEXS1=""
FOR
SET LEXS1=$ORDER(LEXS("L",LEXS1))
if '$LENGTH(LEXS1)
QUIT
SET LEXS2=""
FOR
SET LEXS2=$ORDER(LEXS("L",LEXS1,LEXS2))
if '$LENGTH(LEXS2)
QUIT
Begin DoDot:2
+64 SET LEXS3=""
FOR
SET LEXS3=$ORDER(LEXS("L",LEXS1,LEXS2,LEXS3))
if '$LENGTH(LEXS3)
QUIT
Begin DoDot:3
+65 IF '$DATA(^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3))
Begin DoDot:4
+66 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"7",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$EXTRACT(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3
+67 SET ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3)=""
End DoDot:4
End DoDot:3
End DoDot:2
+68 SET LEXS1=""
FOR
SET LEXS1=$ORDER(LEXS("R",LEXS1))
if '$LENGTH(LEXS1)
QUIT
SET LEXS2=""
FOR
SET LEXS2=$ORDER(LEXS("R",LEXS1,LEXS2))
if '$LENGTH(LEXS2)
QUIT
Begin DoDot:2
+69 SET LEXS3=""
FOR
SET LEXS3=$ORDER(LEXS("R",LEXS1,LEXS2,LEXS3))
if '$LENGTH(LEXS3)
QUIT
Begin DoDot:3
+70 IF '$DATA(^LEX(757.01,"AWRD",LEXS1,LEXS2))
Begin DoDot:4
+71 if $DATA(^LEX(757.04,"ACTION",LEXS1,"B"))!($DATA(^LEX(757.04,"ACTION",LEXS1,"I")))
QUIT
+72 SET LEXERR=+($GET(LEXERR))+1
IF '$DATA(ZTQUEUED)
WRITE !,"8",?8,LEXFI,?19,LEXIDX,?30,"Missing ",$EXTRACT(LEXS1,1,18),?58," ",LEXS2,"/",LEXS3
+73 SET ^LEX(757.01,"AWRD",LEXS1,LEXS2,LEXS3)=""
End DoDot:4
End DoDot:3
End DoDot:2
+74 KILL LEXS
SET LEXS=0
FOR
SET LEXS=$ORDER(^LEX(LEXFI,LEXEXP,5,LEXS))
if +LEXS'>0
QUIT
Begin DoDot:2
+75 NEW DA,DIK
SET DA(1)=LEXEXP
SET DA=LEXS
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO IX1^DIK
End DoDot:2
End DoDot:1
+76 SET LEXEXP=0
FOR
SET LEXEXP=$ORDER(^LEX(757.05,LEXEXP))
if +LEXEXP'>0
QUIT
Begin DoDot:1
+77 NEW DA,DIK
SET DA=LEXEXP
SET DIK="^LEX(757.05,"
DO IX1^DIK
End DoDot:1
+78 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+79 SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+80 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+81 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+82 QUIT
+83 ;
+84 ; Miscellaneous
CLR ; Clear
+1 KILL LEXNAM,LEXTEST,ZTQUEUED
+2 QUIT
