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