LEXRXG ;ISL/KER - Re-Index 757.33 B/C/G ;05/23/2017
;;2.0;LEXICON UTILITY;**81,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.32) SACC 1.3
; ^LEX(757.33) SACC 1.3
; ^TMP("LEXRX",$J) SACC 2.3.2.5.1
;
; External References
; FILE^DID ICR 2052
; IX1^DIK ICR 10013
; IX2^DIK ICR 10013
; IXALL^DIK ICR 10013
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
;
; 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
R75733 ; Repair file 757.33
D RB,RC,RG,R75733^LEXRXG2,R75733^LEXRXG3,SET
Q
RB ; Index ^LEX(757.33,"B",MID,IEN)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
S LEXFI="757.33"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.33 ""B""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXSTR="",LEXFI=757.33,LEXIDX="B",LEXIDXT="^LEX(757.33,""B"",MID,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,LEXID S LEXID=$P($G(^LEX(LEXFI,LEXIEN,0)),"^",1)
. . S LEXOK=0 S:LEXID=LEXSTR LEXOK=1 I 'LEXOK D
. . . S LEXERR=LEXERR+1 K:'$D(LEXTEST) ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
. . . S:$L(LEXID) ^LEX(LEXFI,LEXIDX,LEXID,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 2 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.33,"C",DEF,SRC,ORD,TAR,IEN)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXDEF
S LEXFI="757.33"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.33 ""C""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXDEF="",LEXFI=757.33,LEXIDX="C",LEXIDXT="^LEX(757.33,""C"",EXP,IEN)"
F S LEXDEF=$O(^LEX(LEXFI,LEXIDX,LEXDEF)) Q:'$L(LEXDEF) D
. N LEXSRC S LEXSRC="" F S LEXSRC=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC)) Q:'$L(LEXSRC) D
. . N LEXORD S LEXORD="" F S LEXORD=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD)) Q:'$L(LEXORD) D
. . . N LEXTAR S LEXTAR="" F S LEXTAR=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR)) Q:'$L(LEXTAR) D
. . . . N LEXIEN S LEXIEN="" F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR,LEXIEN)) Q:'$L(LEXIEN) D
. . . . . S LEXNDS=LEXNDS+1 N LEXN0,LEXN3,LEXD,LEXS,LEXO,LEXT S LEXN0=$G(^LEX(757.33,+LEXIEN,0)),LEXN3=$G(^LEX(757.33,+LEXIEN,3))
. . . . . S LEXD=$P(LEXN0,"^",4),LEXS=$P(LEXN0,"^",2),LEXO=$P(LEXN3,"^",1),LEXT=$P(LEXN0,"^",3)
. . . . . Q:'$L(LEXD) Q:'$L(LEXS) Q:'$L(LEXO) Q:'$L(LEXT)
. . . . . I LEXDEF'=LEXD!(LEXSRC'=LEXS)!(LEXORD'=LEXO)!(LEXTAR'=LEXT) D
. . . . . . N DA S DA=LEXIEN S LEXERR=LEXERR+1
. . . . . . K ^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR,LEXIEN)
. . . . . . S ^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA)=""
. . . . . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Invalid ",LEXSRC,"/",LEXTAR,?58," ",DA
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N DA,DIK,X,LEXN0,LEXN3,LEXD,LEXS,LEXO,LEXT S DA=LEXIEN,LEXN0=$G(^LEX(757.33,+LEXIEN,0)),LEXN3=$G(^LEX(757.33,+LEXIEN,3))
. S LEXD=$P(LEXN0,"^",4),LEXS=$P(LEXN0,"^",2),LEXO=$P(LEXN3,"^",1),LEXT=$P(LEXN0,"^",3) Q:'$L(LEXD) Q:'$L(LEXS) Q:'$L(LEXO) Q:'$L(LEXT)
. I '$D(^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA)) D
. . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",LEXS,"/",LEXT,?58," ",DA
. S ^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
H 2 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
RG ; Index ^LEX(757.33,"G",MAP,EFF,STA,IEN,HIS)
N DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXDEF
S LEXFI="757.33"
N LEXTC S LEXTC=$$UPD^LEXRXXT3($G(LEXNAM),,"Repairing File #757.33 ""G""") Q:LEXTC=1
S LEXBEG=$$NOW^XLFDT,(LEXNDS,LEXERR)=0,LEXDEF="",LEXFI=757.33,LEXIDX="G",LEXIDXT="^LEX(757.33,""G"",EXP,IEN)"
F S LEXDEF=$O(^LEX(LEXFI,LEXIDX,LEXDEF)) Q:'$L(LEXDEF) D
. N LEXEFF S LEXEFF="" F S LEXEFF=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF)) Q:'$L(LEXEFF) D
. . N LEXSTA S LEXSTA="" F S LEXSTA=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA)) Q:'$L(LEXSTA) D
. . . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA,LEXIEN)) Q:+LEXIEN'>0 D
. . . . N LEXHIS S LEXHIS=0 F S LEXHIS=$O(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA,LEXIEN,LEXHIS)) Q:+LEXHIS'>0 D
. . . . . S LEXNDS=LEXNDS+1 N LEXN0,LEXHN,LEXD,LEXE,LEXS
. . . . . S LEXN0=$G(^LEX(757.33,+LEXIEN,0)),LEXNH=$G(^LEX(757.33,+LEXIEN,2,+LEXHIS,0))
. . . . . S LEXD=$P(LEXN0,"^",1),LEXE=$P(LEXNH,"^",1),LEXS=$P(LEXNH,"^",2)
. . . . . Q:'$L(LEXD) Q:'$L(LEXE) Q:'$L(LEXS)
. . . . . I LEXDEF'=LEXD!(LEXEFF'=LEXE)!(LEXSTA'=LEXS) D
. . . . . . N DA,LEXED,LEXSD S DA(1)=LEXIEN,DA=LEXHIS S LEXERR=LEXERR+1
. . . . . . S LEXED=$TR($$FMTE^XLFDT(LEXEFF,"5DZ"),"@"," ")
. . . . . . S LEXSD=$S(+LEXSTA>0:"Active",1:"Inactive")
. . . . . . K ^LEX(757.33,"G",LEXDEF,LEXEFF,LEXSTA,DA(1))
. . . . . . S ^LEX(757.33,"G",LEXD,LEXE,LEXS,DA(1))=""
. . . . . . S ^LEX(757.33,"G",LEXD,LEXE,LEXS,DA(1),DA)=""
. . . . . . I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Invalid ",LEXED," ",LEXSD,?58," ",DA(1),"/",DA
S LEXIEN=0 F S LEXIEN=$O(^LEX(LEXFI,LEXIEN)) Q:+LEXIEN'>0 D
. N LEXHIS S LEXHIS=0 F S LEXHIS=$O(^LEX(LEXFI,LEXIEN,2,LEXHIS)) Q:+LEXHIS'>0 D
. . N DA,DIK,X,LEXN0,LEXHN,LEXD,LEXE,LEXS,LEXED,LEXSD
. . S DA(1)=LEXIEN,DA=LEXHIS
. . S LEXN0=$G(^LEX(757.33,+LEXIEN,0))
. . S LEXNH=$G(^LEX(757.33,+LEXIEN,2,+LEXHIS,0))
. . S LEXD=$P(LEXN0,"^",1),LEXE=$P(LEXNH,"^",1),LEXS=$P(LEXNH,"^",2) Q:'$L(LEXD) Q:'$L(LEXE) Q:'$L(LEXS)
. . S LEXED=$TR($$FMTE^XLFDT(LEXE,"5DZ"),"@"," ")
. . S LEXSD=$S(+LEXS>0:"Active",1:"Inactive")
. . I $D(^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1)))<11 D
. . . S LEXERR=LEXERR+1 I '$D(ZTQUEUED) W !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",LEXED," ",LEXSD,?58," ",DA(1),"/",DA
. . S ^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1))=""
. . S ^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1),DA)=""
S LEXERR=$S(+LEXERR>0:LEXERR,1:"") I '$D(ZTQUEUED) W !,$J(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
H 2 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
SET ; Re-Index Subset file 757.33 (Set logic only)
Q:'$D(LEXSET) N LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
N LEXOUT,LEXMSG S LEXFI=757.33
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
. 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 D
. N ZTQUEUED,DIK S ZTQUEUED=$G(ZTQUEUED) S DIK="^LEX("_LEXFI_"," D IXALL^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 Inactive Mappings 757.33
N DA,DIK,LEXDEF,LEXEF,LEXEF1,LEXHIS,LEXMAP,LEXN0,LEXNC,LEXNE,LEXNEXT
N LEXNH,LEXNS,LEXSCODE,LEXSEFF,LEXSIEN,LEXSNOM,LEXSRC,LEXSSAB,LEXSSTA
N LEXSSYS,LEXST,LEXTCODE,LEXTD,LEXTEFF,LEXTIEN,LEXTNON,LEXTSAB
N LEXTSTA,LEXTSYS S LEXTD=$$DT^XLFDT,DA=+($G(X)) Q:+DA'>0
Q:'$D(^LEX(757.33,DA,0)) Q:'$D(^LEX(757.33,DA,2))
S LEXN0=$G(^LEX(757.33,DA,0))
S LEXEF=$O(^LEX(757.33,+DA,2,"B",(LEXTD+.001)),-1) Q:LEXEF'?7N
S LEXEF1=$$FMADD^XLFDT(LEXEF,1) Q:LEXEF1'?7N Q:LEXEF1'<LEXTD
S LEXHIS=$O(^LEX(757.33,+DA,2,"B",+LEXEF," "),-1)
S LEXNH=$G(^LEX(757.33,+DA,2,+LEXHIS,0)) S LEXST=$P(LEXNH,"^",2)
Q:LEXST'>0 S LEXSCODE=$P(LEXN0,"^",2) S LEXTCODE=$P(LEXN0,"^",3)
S LEXMAP=$P(LEXN0,"^",4) S LEXDEF=$G(^LEX(757.32,+LEXMAP,2))
S LEXSSYS=$P(LEXDEF,"^",1),LEXTSYS=$P(LEXDEF,"^",2)
S LEXSRC=$G(^LEX(757.03,LEXSSYS,0))
S LEXSSAB=$E(LEXSRC,1,3),LEXSNOM=$P(LEXSRC,"^",2)
S LEXSRC=$G(^LEX(757.03,LEXTSYS,0))
S LEXTSAB=$E(LEXSRC,1,3),LEXTNON=$P(LEXSRC,"^",2)
S LEXSSTA=$$STATCHK^LEXSRC2(LEXSCODE,LEXTD,,LEXSSAB)
S LEXSIEN=$P(LEXSSTA,"^",2),LEXSEFF=$P(LEXSSTA,"^",3)
S LEXTSTA=$$STATCHK^LEXSRC2(LEXTCODE,LEXTD,,LEXTSAB)
S LEXTIEN=$P(LEXTSTA,"^",2),LEXTEFF=$P(LEXSSTA,"^",3)
Q:+LEXSSTA>0&(+LEXTSTA>0) S LEXNEXT=$O(^LEX(757.33,+DA,2," "),-1)+1
S LEXNS=0,LEXNE=LEXEF1,LEXNC=$$NOW^XLFDT I $D(LEXFIX) D
. N DIK S DIK="^LEX(757.33," D IX2^DIK
. S ^LEX(757.33,+DA,2,0)="^757.333D^"_LEXNEXT_"^"_LEXNEXT
. S ^LEX(757.33,+DA,2,+LEXNEXT,0)=LEXNE_"^"_LEXNS_"^"_LEXNC
. W:'$D(ZTQUEUED) "."
. S DIK="^LEX(757.33," D IX1^DIK
Q
CLR ; Clear
K LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXRXG 10592 printed Dec 13, 2024@02:09:21 Page 2
LEXRXG ;ISL/KER - Re-Index 757.33 B/C/G ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**81,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.32) SACC 1.3
+5 ; ^LEX(757.33) SACC 1.3
+6 ; ^TMP("LEXRX",$J) SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; FILE^DID ICR 2052
+10 ; IX1^DIK ICR 10013
+11 ; IX2^DIK ICR 10013
+12 ; IXALL^DIK ICR 10013
+13 ; $$DT^XLFDT ICR 10103
+14 ; $$FMADD^XLFDT ICR 10103
+15 ; $$FMDIFF^XLFDT ICR 10103
+16 ; $$FMTE^XLFDT ICR 10103
+17 ; $$NOW^XLFDT ICR 10103
+18 ;
+19 ; Local Variables NEWed or KILLed Elsewhere
+20 ; LEXFIX Fix Index flag NEWed/KILLed by LEXRXXT
+21 ; LEXNAM Task name NEWed/KILLed by LEXRXXT
+22 ; LEXSET Re-Index flag NEWed/KILLed by LEXRXXT
+23 ; LEXQ Quiet flat NEWed/KILLed by LEXRXXT2
+24 ; LEXTEST Test variable NEWed/KILLed by Developer
+25 ; ZTQUEUED Task flag NEWed/KILLed by Taskman
+26 ;
+27 QUIT
EN ; Main Entry Point
R75733 ; Repair file 757.33
+1 DO RB
DO RC
DO RG
DO R75733^LEXRXG2
DO R75733^LEXRXG3
DO SET
+2 QUIT
RB ; Index ^LEX(757.33,"B",MID,IEN)
+1 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXSTR
+2 SET LEXFI="757.33"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.33 ""B""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXSTR=""
SET LEXFI=757.33
SET LEXIDX="B"
SET LEXIDXT="^LEX(757.33,""B"",MID,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,LEXID
SET LEXID=$PIECE($GET(^LEX(LEXFI,LEXIEN,0)),"^",1)
+8 SET LEXOK=0
if LEXID=LEXSTR
SET LEXOK=1
IF 'LEXOK
Begin DoDot:3
+9 SET LEXERR=LEXERR+1
if '$DATA(LEXTEST)
KILL ^LEX(LEXFI,LEXIDX,LEXSTR,LEXIEN)
+10 if $LENGTH(LEXID)
SET ^LEX(LEXFI,LEXIDX,LEXID,LEXIEN)=""
+11 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,LEXSTR,?58," ",LEXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+13 NEW DA,DIK,X
SET DA=LEXIEN
SET X=$PIECE($GET(^LEX(LEXFI,DA,0)),"^",1)
if '$LENGTH(X)
QUIT
+14 IF '$DATA(^LEX(LEXFI,LEXIDX,X,DA))
Begin DoDot:2
+15 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",X,?58," ",DA
End DoDot:2
+16 if $LENGTH(X)
SET ^LEX(LEXFI,LEXIDX,X,DA)=""
End DoDot:1
+17 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+18 HANG 2
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+19 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+20 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+21 QUIT
RC ; Index ^LEX(757.33,"C",DEF,SRC,ORD,TAR,IEN)
+1 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXDEF
+2 SET LEXFI="757.33"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.33 ""C""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXDEF=""
SET LEXFI=757.33
SET LEXIDX="C"
SET LEXIDXT="^LEX(757.33,""C"",EXP,IEN)"
+5 FOR
SET LEXDEF=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF))
if '$LENGTH(LEXDEF)
QUIT
Begin DoDot:1
+6 NEW LEXSRC
SET LEXSRC=""
FOR
SET LEXSRC=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC))
if '$LENGTH(LEXSRC)
QUIT
Begin DoDot:2
+7 NEW LEXORD
SET LEXORD=""
FOR
SET LEXORD=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD))
if '$LENGTH(LEXORD)
QUIT
Begin DoDot:3
+8 NEW LEXTAR
SET LEXTAR=""
FOR
SET LEXTAR=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR))
if '$LENGTH(LEXTAR)
QUIT
Begin DoDot:4
+9 NEW LEXIEN
SET LEXIEN=""
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR,LEXIEN))
if '$LENGTH(LEXIEN)
QUIT
Begin DoDot:5
+10 SET LEXNDS=LEXNDS+1
NEW LEXN0,LEXN3,LEXD,LEXS,LEXO,LEXT
SET LEXN0=$GET(^LEX(757.33,+LEXIEN,0))
SET LEXN3=$GET(^LEX(757.33,+LEXIEN,3))
+11 SET LEXD=$PIECE(LEXN0,"^",4)
SET LEXS=$PIECE(LEXN0,"^",2)
SET LEXO=$PIECE(LEXN3,"^",1)
SET LEXT=$PIECE(LEXN0,"^",3)
+12 if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXS)
QUIT
if '$LENGTH(LEXO)
QUIT
if '$LENGTH(LEXT)
QUIT
+13 IF LEXDEF'=LEXD!(LEXSRC'=LEXS)!(LEXORD'=LEXO)!(LEXTAR'=LEXT)
Begin DoDot:6
+14 NEW DA
SET DA=LEXIEN
SET LEXERR=LEXERR+1
+15 KILL ^LEX(LEXFI,LEXIDX,LEXDEF,LEXSRC,LEXORD,LEXTAR,LEXIEN)
+16 SET ^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA)=""
+17 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Invalid ",LEXSRC,"/",LEXTAR,?58," ",DA
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+19 NEW DA,DIK,X,LEXN0,LEXN3,LEXD,LEXS,LEXO,LEXT
SET DA=LEXIEN
SET LEXN0=$GET(^LEX(757.33,+LEXIEN,0))
SET LEXN3=$GET(^LEX(757.33,+LEXIEN,3))
+20 SET LEXD=$PIECE(LEXN0,"^",4)
SET LEXS=$PIECE(LEXN0,"^",2)
SET LEXO=$PIECE(LEXN3,"^",1)
SET LEXT=$PIECE(LEXN0,"^",3)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXS)
QUIT
if '$LENGTH(LEXO)
QUIT
if '$LENGTH(LEXT)
QUIT
+21 IF '$DATA(^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA))
Begin DoDot:2
+22 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",LEXS,"/",LEXT,?58," ",DA
End DoDot:2
+23 SET ^LEX(LEXFI,LEXIDX,LEXD,LEXS,LEXO,LEXT,DA)=""
End DoDot:1
+24 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+25 HANG 2
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+26 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+27 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+28 QUIT
RG ; Index ^LEX(757.33,"G",MAP,EFF,STA,IEN,HIS)
+1 NEW DA,DIK,LEXBEG,LEXDIF,LEXELP,LEXEND,LEXERR,LEXFI,LEXIDX,LEXIDXT,LEXIEN,LEXMC,LEXNDS,LEXOK,LEXDEF
+2 SET LEXFI="757.33"
+3 NEW LEXTC
SET LEXTC=$$UPD^LEXRXXT3($GET(LEXNAM),,"Repairing File #757.33 ""G""")
if LEXTC=1
QUIT
+4 SET LEXBEG=$$NOW^XLFDT
SET (LEXNDS,LEXERR)=0
SET LEXDEF=""
SET LEXFI=757.33
SET LEXIDX="G"
SET LEXIDXT="^LEX(757.33,""G"",EXP,IEN)"
+5 FOR
SET LEXDEF=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF))
if '$LENGTH(LEXDEF)
QUIT
Begin DoDot:1
+6 NEW LEXEFF
SET LEXEFF=""
FOR
SET LEXEFF=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF))
if '$LENGTH(LEXEFF)
QUIT
Begin DoDot:2
+7 NEW LEXSTA
SET LEXSTA=""
FOR
SET LEXSTA=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA))
if '$LENGTH(LEXSTA)
QUIT
Begin DoDot:3
+8 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:4
+9 NEW LEXHIS
SET LEXHIS=0
FOR
SET LEXHIS=$ORDER(^LEX(LEXFI,LEXIDX,LEXDEF,LEXEFF,LEXSTA,LEXIEN,LEXHIS))
if +LEXHIS'>0
QUIT
Begin DoDot:5
+10 SET LEXNDS=LEXNDS+1
NEW LEXN0,LEXHN,LEXD,LEXE,LEXS
+11 SET LEXN0=$GET(^LEX(757.33,+LEXIEN,0))
SET LEXNH=$GET(^LEX(757.33,+LEXIEN,2,+LEXHIS,0))
+12 SET LEXD=$PIECE(LEXN0,"^",1)
SET LEXE=$PIECE(LEXNH,"^",1)
SET LEXS=$PIECE(LEXNH,"^",2)
+13 if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXE)
QUIT
if '$LENGTH(LEXS)
QUIT
+14 IF LEXDEF'=LEXD!(LEXEFF'=LEXE)!(LEXSTA'=LEXS)
Begin DoDot:6
+15 NEW DA,LEXED,LEXSD
SET DA(1)=LEXIEN
SET DA=LEXHIS
SET LEXERR=LEXERR+1
+16 SET LEXED=$TRANSLATE($$FMTE^XLFDT(LEXEFF,"5DZ"),"@"," ")
+17 SET LEXSD=$SELECT(+LEXSTA>0:"Active",1:"Inactive")
+18 KILL ^LEX(757.33,"G",LEXDEF,LEXEFF,LEXSTA,DA(1))
+19 SET ^LEX(757.33,"G",LEXD,LEXE,LEXS,DA(1))=""
+20 SET ^LEX(757.33,"G",LEXD,LEXE,LEXS,DA(1),DA)=""
+21 IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Invalid ",LEXED," ",LEXSD,?58," ",DA(1),"/",DA
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(LEXFI,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:1
+23 NEW LEXHIS
SET LEXHIS=0
FOR
SET LEXHIS=$ORDER(^LEX(LEXFI,LEXIEN,2,LEXHIS))
if +LEXHIS'>0
QUIT
Begin DoDot:2
+24 NEW DA,DIK,X,LEXN0,LEXHN,LEXD,LEXE,LEXS,LEXED,LEXSD
+25 SET DA(1)=LEXIEN
SET DA=LEXHIS
+26 SET LEXN0=$GET(^LEX(757.33,+LEXIEN,0))
+27 SET LEXNH=$GET(^LEX(757.33,+LEXIEN,2,+LEXHIS,0))
+28 SET LEXD=$PIECE(LEXN0,"^",1)
SET LEXE=$PIECE(LEXNH,"^",1)
SET LEXS=$PIECE(LEXNH,"^",2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXE)
QUIT
if '$LENGTH(LEXS)
QUIT
+29 SET LEXED=$TRANSLATE($$FMTE^XLFDT(LEXE,"5DZ"),"@"," ")
+30 SET LEXSD=$SELECT(+LEXS>0:"Active",1:"Inactive")
+31 IF $DATA(^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1)))<11
Begin DoDot:3
+32 SET LEXERR=LEXERR+1
IF '$DATA(ZTQUEUED)
WRITE !,?8,LEXFI,?19,LEXIDX,?30,"Missing ",LEXED," ",LEXSD,?58," ",DA(1),"/",DA
End DoDot:3
+33 SET ^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1))=""
+34 SET ^LEX(LEXFI,LEXIDX,LEXD,LEXE,LEXS,DA(1),DA)=""
End DoDot:2
End DoDot:1
+35 SET LEXERR=$SELECT(+LEXERR>0:LEXERR,1:"")
IF '$DATA(ZTQUEUED)
WRITE !,$JUSTIFY(LEXERR,5),?8,LEXFI,?19,LEXIDX,?30,LEXIDXT
+36 HANG 2
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT(LEXEND,LEXBEG,3)
+37 if $EXTRACT(LEXELP,1)=" "&($EXTRACT(LEXELP,3)="
SET LEXELP=$TRANSLATE(LEXELP," ","0")
+38 DO REP^LEXRXXS(LEXFI,LEXFI,LEXIDX,LEXNDS,LEXERR,LEXIDXT,LEXELP)
+39 QUIT
+40 ;
+41 ; Miscellaneous
SET ; Re-Index Subset file 757.33 (Set logic only)
+1 if '$DATA(LEXSET)
QUIT
NEW LEXTC,LEXPRE,LEXBEG,LEXEND,LEXELP,LEXNM,LEXFI,LEXRT
+2 NEW LEXOUT,LEXMSG
SET LEXFI=757.33
+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 if $DATA(LEXFIX)
DO FIX(LEXIEN)
IF $DATA(^LEX(LEXFI,+LEXIEN,0))
SET LEXP3=LEXIEN
SET LEXP4=LEXP4+1
End DoDot:1
+12 if LEXP3>0
SET $PIECE(^LEX(LEXFI,0),"^",3)=LEXP3
if LEXP4>0
SET $PIECE(^LEX(LEXFI,0),"^",4)=LEXP4
+13 IF +($GET(LEXP4))>0
Begin DoDot:1
+14 NEW ZTQUEUED,DIK
SET ZTQUEUED=$GET(ZTQUEUED)
SET DIK="^LEX("_LEXFI_","
DO IXALL^DIK
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 Inactive Mappings 757.33
+1 NEW DA,DIK,LEXDEF,LEXEF,LEXEF1,LEXHIS,LEXMAP,LEXN0,LEXNC,LEXNE,LEXNEXT
+2 NEW LEXNH,LEXNS,LEXSCODE,LEXSEFF,LEXSIEN,LEXSNOM,LEXSRC,LEXSSAB,LEXSSTA
+3 NEW LEXSSYS,LEXST,LEXTCODE,LEXTD,LEXTEFF,LEXTIEN,LEXTNON,LEXTSAB
+4 NEW LEXTSTA,LEXTSYS
SET LEXTD=$$DT^XLFDT
SET DA=+($GET(X))
if +DA'>0
QUIT
+5 if '$DATA(^LEX(757.33,DA,0))
QUIT
if '$DATA(^LEX(757.33,DA,2))
QUIT
+6 SET LEXN0=$GET(^LEX(757.33,DA,0))
+7 SET LEXEF=$ORDER(^LEX(757.33,+DA,2,"B",(LEXTD+.001)),-1)
if LEXEF'?7N
QUIT
+8 SET LEXEF1=$$FMADD^XLFDT(LEXEF,1)
if LEXEF1'?7N
QUIT
if LEXEF1'<LEXTD
QUIT
+9 SET LEXHIS=$ORDER(^LEX(757.33,+DA,2,"B",+LEXEF," "),-1)
+10 SET LEXNH=$GET(^LEX(757.33,+DA,2,+LEXHIS,0))
SET LEXST=$PIECE(LEXNH,"^",2)
+11 if LEXST'>0
QUIT
SET LEXSCODE=$PIECE(LEXN0,"^",2)
SET LEXTCODE=$PIECE(LEXN0,"^",3)
+12 SET LEXMAP=$PIECE(LEXN0,"^",4)
SET LEXDEF=$GET(^LEX(757.32,+LEXMAP,2))
+13 SET LEXSSYS=$PIECE(LEXDEF,"^",1)
SET LEXTSYS=$PIECE(LEXDEF,"^",2)
+14 SET LEXSRC=$GET(^LEX(757.03,LEXSSYS,0))
+15 SET LEXSSAB=$EXTRACT(LEXSRC,1,3)
SET LEXSNOM=$PIECE(LEXSRC,"^",2)
+16 SET LEXSRC=$GET(^LEX(757.03,LEXTSYS,0))
+17 SET LEXTSAB=$EXTRACT(LEXSRC,1,3)
SET LEXTNON=$PIECE(LEXSRC,"^",2)
+18 SET LEXSSTA=$$STATCHK^LEXSRC2(LEXSCODE,LEXTD,,LEXSSAB)
+19 SET LEXSIEN=$PIECE(LEXSSTA,"^",2)
SET LEXSEFF=$PIECE(LEXSSTA,"^",3)
+20 SET LEXTSTA=$$STATCHK^LEXSRC2(LEXTCODE,LEXTD,,LEXTSAB)
+21 SET LEXTIEN=$PIECE(LEXTSTA,"^",2)
SET LEXTEFF=$PIECE(LEXSSTA,"^",3)
+22 if +LEXSSTA>0&(+LEXTSTA>0)
QUIT
SET LEXNEXT=$ORDER(^LEX(757.33,+DA,2," "),-1)+1
+23 SET LEXNS=0
SET LEXNE=LEXEF1
SET LEXNC=$$NOW^XLFDT
IF $DATA(LEXFIX)
Begin DoDot:1
+24 NEW DIK
SET DIK="^LEX(757.33,"
DO IX2^DIK
+25 SET ^LEX(757.33,+DA,2,0)="^757.333D^"_LEXNEXT_"^"_LEXNEXT
+26 SET ^LEX(757.33,+DA,2,+LEXNEXT,0)=LEXNE_"^"_LEXNS_"^"_LEXNC
+27 if '$DATA(ZTQUEUED)
WRITE "."
+28 SET DIK="^LEX(757.33,"
DO IX1^DIK
End DoDot:1
+29 QUIT
CLR ; Clear
+1 KILL LEXFIX,LEXNAM,LEXSET,LEXTEST,ZTQUEUED,LEXQ
+2 QUIT
