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