LEXXGU2.m

LEXXGU2 ;ISL/KER - Global Uninstall (^LEXU) ;05/23/2017

 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 ;               

 ; Global Variables

 ;    ^LEXU               N/A

 ;    ^TMP("LEXXGUM")     SACC 2.3.2.5.1

 ;               

 ; External References

 ;    $$S^%ZTLOAD         ICR  10063

 ;    ^DIC                ICR  10006

 ;    FIND^DIC            ICR   2051

 ;    ^DIK                ICR  10013

 ;    $$IENS^DILF         ICR   2054

 ;    $$GET1^DIQ          ICR   2056

 ;    ^DIR                ICR  10026

 ;    $$DT^XLFDT          ICR  10103

 ;    $$FMTE^XLFDT        ICR  10103

 ;    ^XMD                ICR  10070

 ;    $$PKG^XPDUTL        ICR  10141

 ;    $$VERSION^XPDUTL    ICR  10141

 ;    $$VER^XPDUTL        ICR  10141

 ;               

 ; Local Variables NEWed or KILLed Elsewhere

 ;     LEXUNDO            NEWed in LEXXGU

 ;  

FILES ;   Load Data for all files

 S:'$L($G(LEXB)) LEXB=$G(LEXBLD) S:'$L($G(LEXB)) LEXB=$G(^LEXU(0,"BUILD")) Q:'$L($G(LEXB))

 N LEXHDR,LEXBLD,LEXDAT,LEXFI,LEXFIC,LEXINS,LEXTOTI,LEXTOTN,LEXPER,LEXPRE,LEXOK

 S (LEXFI,LEXFIC,LEXHDR,LEXTOTI,LEXTOTN,LEXPER,LEXPRE)=0,LEXBLD=LEXB,LEXOK=1

 S LEXDAT=$P($G(^LEXU(0,"VRRVDT")),"^",1),LEXINS=1

 S:+LEXDAT'>0 LEXDAT=$$DT^XLFDT I LEXOK D

 . N LEXCRE,LEXL1 S LEXL1="" S LEXCRE=$G(^LEXU(0,"CREATED")) S LEXCRE=$S(+LEXCRE>0:($$MIX($$FMTE^XLFDT(LEXCRE))),1:"")

 . S:$L($P(LEXCRE,"@",2)) LEXCRE=$P(LEXCRE,"@",1)_" at "_$P(LEXCRE,"@",2) S LEXL1=" Uninstalling data "

 . S:$L($G(LEXCRE))&($L($G(LEXL1))) LEXL1=$G(LEXL1)_"using Undo-Global ^LEXU created "_$G(LEXCRE)

 . D PB(LEXL1)

 S LEXFI=0 F  S LEXFI=$O(^LEXU(LEXFI)) Q:+LEXFI=0  S LEXTOTN=+($G(LEXTOTN))+($O(^LEXU(LEXFI," "),-1))

 S LEXFI=0 F  S LEXFI=$O(^LEXU(LEXFI)) Q:+LEXFI=0  D FILE

 Q

FILE ;     Load Data for one file

 N LEXCHG,LEXCNT,LEXFIL,LEXFIR,LEXI,LEXL,LEXLC

 N LEXMUMPS,LEXNM,LEXRT,LEXS,LEXTOT,LEXTXT

 S LEXFIR=$O(^LEXU(($P(LEXFI,".",1)-.000001)))

 S (LEXCNT,LEXLC,LEXI)=0,LEXL=68,LEXFIC=LEXFIC+1 I LEXOK D

 . N LEXB,LEXFID,LEXNM,LEXVR,LEXRV,LEXDT,LEXL1 S LEXL1="",LEXFID=$P(LEXFI,".",1) Q:+LEXFID'>0

 . S:LEXFID=80 LEXNM="ICD Files" S:LEXFID=81 LEXNM="CPT-4/HCPCS" S:LEXFID=757 LEXNM="Lexicon" S LEXB=$G(^LEXU(LEXFI,0,"BUILD"))

 . S LEXVR=$G(^LEXU(LEXFI,0,"VR")),LEXRV=$G(^LEXU(LEXFI,0,"VRRV")),LEXDT=$$MIX($$FMTE^XLFDT($P(LEXRV,"^",2))),LEXRV=$P(LEXRV,"^",1)

 . Q:'$L(LEXNM)  S LEXL1="Uninstalling data for "_LEXNM S LEXL1=" "_LEXL1 D:LEXFI=LEXFIR BL,TL(LEXL1) D:$G(LEXNM)'["ICD F" BL

 S LEXTOT=+($G(^LEXU(LEXFI,0))) G:LEXTOT=0 FILEQ

 S LEXNM=$G(^LEXU(LEXFI,0,"NM"))

 I $L(LEXNM),$$UP(LEXNM)'["FILE" S LEXNM=LEXNM_" FILE"

 S:$L(LEXNM) LEXNM=$$MIX(LEXNM) S LEXCHG=$G(^LEXU(LEXFI,0))

 S LEXTXT="   "_LEXNM,LEXTXT=LEXTXT_$J("",(40-$L(LEXTXT)))_LEXFI

 D:LEXFIC=1 PB(LEXTXT) D:LEXFIC'=1 TL(LEXTXT)

 S LEXS=+(LEXTOT\LEXL) S:LEXS=0 LEXS=1 W:+($O(^LEXU(LEXFI,0)))>0 !,"   "

 F  S LEXI=$O(^LEXU(LEXFI,LEXI)) Q:+LEXI=0  D

 . S LEXCNT=LEXCNT+1,LEXMUMPS=$G(^LEXU(LEXFI,LEXI))

 . I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0

 . S LEXRT=$P(LEXMUMPS,"^",2),LEXFIL=""

 . S:LEXMUMPS["^LEX("!(LEXMUMPS["^LEXT(")!(LEXMUMPS["^LEXC(") LEXFIL=+($P(LEXRT,"(",2))

 . S:LEXMUMPS["^ICD9(" LEXFIL=80 S:LEXMUMPS["^ICD0(" LEXFIL=80.1 S:LEXMUMPS["^ICPT(" LEXFIL=81

 . S:LEXMUMPS["^DIC(81.1" LEXFIL=81.1 S:LEXMUMPS["^DIC(81.2" LEXFIL=81.2 S:LEXMUMPS["^DIC(81.3" LEXFIL=81.3

 . I $L(LEXMUMPS) D

 . . X LEXMUMPS S LEXUNDO=1,LEXTOTI=+($G(LEXTOTI))+1 I +($G(LEXTOTN))>0,+($G(LEXTOTI))>0,$D(ZTQUEUED),+($G(ZTSK))>0 D

 . . . N LEXT,LEXTSK S (LEXT,LEXPER)=(+($G(LEXTOTI))/+($G(LEXTOTN)))*100 Q:+LEXPER-(+($G(LEXPRE)))'>2  S LEXPRE=+($G(LEXPER))

 . . . S LEXPER=$J(LEXPER,6,2) I +LEXT>0 S LEXPER=LEXPER_"% complete" S LEXTSK=$$S^%ZTLOAD(LEXPER)

 . . . N ZTQUEUED,ZTSK

FILEQ ;     Load Data for one file - QUIT

 Q

 ; 

CHK(X) ; Check Versions

 N DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,CHK,AFT,PRE,AEF,PEF,REV,BLD K CHK D REVS(.CHK) S BLD=$P($G(CHK("LEXU",1)),"^",1)

 I +($G(CHK("LEXU")))'>0 W !!,"   Undo-Global ^LEXU Build not found",! Q 0

 I +($G(CHK("LEXU")))'=+($G(CHK("LEX"))) W !!,"   Undo-Global ^LEXU Build is invalid",! Q 0

 I '$D(CHK("LEX"))&('$D(CHK("CPT")))&('$D(CHK("ICD"))) W !!,"   Current/Past Builds not found",! Q 0

 S AFT=$P($G(CHK("LEX")),"^",1),PRE=$P($G(CHK("LEX")),"^",3)

 I AFT'>0!(PRE'>0)!(AFT'>PRE) D  Q 0

 . W !!,"   Current/Past Builds are invalid",!

 S REV=$G(CHK("LEX",1)),AFT=$P(REV,"^",1),AEF=$P(REV,"^",2),PRE=$P(REV,"^",3),PEF=$P(REV,"^",4)

 I '$L(REV)!('$L(AFT))!('$L(AEF))!('$L(PRE))!('$L(PEF)) W !!,"   Primary Build not found",! Q 0

 I $D(TEST) W !!," Uninstall" W:$L($G(BLD)) " Patch ",BLD W ":"

 W !!,"   Uninstall Build",?36,"Revert to"

 W !,"   --------------------------",?36,"--------------------------"

 W !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF

 S REV=$G(CHK("ICD",1)),AFT=$P(REV,"^",1),AEF=$P(REV,"^",2),PRE=$P(REV,"^",3),PEF=$P(REV,"^",4)

 I $L(AFT),$L(AEF),$L(PRE),$L(PEF) W !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF

 S REV=$G(CHK("CPT",1)),AFT=$P(REV,"^",1),AEF=$P(REV,"^",2),PRE=$P(REV,"^",3),PEF=$P(REV,"^",4)

 I $L(AFT),$L(AEF),$L(PRE),$L(PEF) W !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF

 S:$L(BLD) DIR("A")=" Uninstall patch "_BLD_" (Y/N):  " S:'$L(BLD) DIR("A")=" Uninstall patch (Y/N):  "

 S DIR("B")="NO",DIR(0)="YAO" W ! D ^DIR S X=+Y S:"^1^0^"'[("^"_Y_"^") X="^" N TEST

 Q X

 ; 

 ; Miscellaneous

MAIL ;   Mail Message

 Q:'$D(^TMP("LEXXGUM",$J))  Q:'$L($G(LEXSUB))  N XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,LEXJ,LEXNM

 S XMTEXT="^TMP(""LEXXGUM"","_$J_",",XMSUB=$G(LEXSUB),LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01) S XMY(("G.LEXINS@"_$$XMA))=""

 S XMY(LEXNM)="",XMDUZ=.5 D ^XMD I '$D(ZTQUEUED),+($G(XMZ))>0 D

 . W !!," ",LEXSUB," Message #",($G(XMZ))," sent"

XMSQ ;   Send Message (Quit)

 K ^TMP("LEXXGUM",$J),LEXNM,LEXSUB

 Q

REVS(ARY) ;  Revisions

 N FI,EFF,AFT,PRE,REV,VER K ARY S REV=$P($G(^LEXU(0,"BUILD")),"*",3)

 I $L(REV) D

 . N EFF S ARY("LEXU")=REV,VER=$$VERSION^XPDUTL("LEX") I $L($G(ARY("LEXU")))&(+VER>0) D

 . S ARY("LEXU","1")="LEX*"_VER_"*"_REV S EFF=$P($G(^LEXU(0,"VRRVDT")),"^",1)

 . S:EFF?7N $P(ARY("LEXU","1"),"^",2)=EFF

  F FI=80,80.1 D

 . Q:'$D(^LEXU(FI))  N IEN,AFT,PRE S AFT=$G(^LEXU(FI,0,"VRRV")),IEN=$O(^LEXU(FI," "),-1)

 . S PRE=$TR($P($G(^LEXU(FI,IEN)),"=",2),"""","")

 . I +AFT>0,+PRE>0,+AFT>++PRE,+($P(AFT,"^",2))?7N D

 . . S ARY("ICD",+($P(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE

 S EFF=$O(ARY("ICD"," "),-1),AFT=$O(ARY("ICD",+EFF," "),-1),PRE=$O(ARY("ICD",+EFF,+AFT," "),-1)

 S REV=$G(ARY("ICD",+EFF,+AFT,+PRE)) K ARY("ICD") I $L(REV) D

 . S ARY("ICD")=REV,VER=$$VERSION^XPDUTL("ICD") I $L($G(ARY("ICD")))&(+VER>0) D

 . . S AFT="ICD*"_VER_"*"_+($P($G(ARY("ICD")),"^",1))_"^"_$S($P($G(ARY("ICD")),"^",2)?7N:$$FMTE^XLFDT($P($G(ARY("ICD")),"^",2)),1:"")

 . . S PRE="ICD*"_VER_"*"_+($P($G(ARY("ICD")),"^",3))_"^"_$S($P($G(ARY("ICD")),"^",4)?7N:$$FMTE^XLFDT($P($G(ARY("ICD")),"^",4)),1:"")

 . . S ARY("ICD","1")=AFT_"^"_PRE

 F FI=81,81.1,81.2,81.3 D

 . Q:'$D(^LEXU(FI))  N IEN,AFT,PRE S AFT=$G(^LEXU(FI,0,"VRRV")),IEN=$O(^LEXU(FI," "),-1)

 . S PRE=$TR($P($G(^LEXU(FI,IEN)),"=",2),"""","")

 . I +AFT>0,+PRE>0,+AFT>++PRE,+($P(AFT,"^",2))?7N D

 . . S ARY("CPT",+($P(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE

 S EFF=$O(ARY("CPT"," "),-1),AFT=$O(ARY("CPT",+EFF," "),-1),PRE=$O(ARY("CPT",+EFF,+AFT," "),-1)

 S REV=$G(ARY("CPT",+EFF,+AFT,+PRE)) K ARY("CPT") I $L(REV) D

 . S ARY("CPT")=REV,VER=$$VERSION^XPDUTL("ICPT") I $L($G(ARY("CPT")))&(+VER>0) D

 . . S AFT="ICPT*"_VER_"*"_+($P($G(ARY("CPT")),"^",1))_"^"_$S($P($G(ARY("CPT")),"^",2)?7N:$$FMTE^XLFDT($P($G(ARY("CPT")),"^",2)),1:"")

 . . S PRE="ICPT*"_VER_"*"_+($P($G(ARY("CPT")),"^",3))_"^"_$S($P($G(ARY("CPT")),"^",4)?7N:$$FMTE^XLFDT($P($G(ARY("CPT")),"^",4)),1:"")

 . . S ARY("CPT","1")=AFT_"^"_PRE

 S FI=756.9999 F  S FI=$O(@("^DIC("_+FI_")")) Q:+FI'>0!($P(FI,".",1)'=757)!(FI>757.41)  D

 . Q:'$D(^LEXU(FI))  N IEN,AFT,PRE S AFT=$G(^LEXU(FI,0,"VRRV")),IEN=$O(^LEXU(FI," "),-1)

 . S PRE=$TR($P($G(^LEXU(FI,IEN)),"=",2),"""","") I +AFT>0,+PRE>0,+AFT>++PRE,+($P(AFT,"^",2))?7N D

 . . S ARY("LEX",+($P(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE

 S EFF=$O(ARY("LEX"," "),-1),AFT=$O(ARY("LEX",+EFF," "),-1),PRE=$O(ARY("LEX",+EFF,+AFT," "),-1)

 S REV=$G(ARY("LEX",+EFF,+AFT,+PRE)) K ARY("LEX") I $L(REV) D

 . S ARY("LEX")=REV,VER=$$VERSION^XPDUTL("LEX") I $L($G(ARY("LEX")))&(+VER>0) D

 . . S AFT="LEX*"_VER_"*"_+($P($G(ARY("LEX")),"^",1))_"^"_$S($P($G(ARY("LEX")),"^",2)?7N:$$FMTE^XLFDT($P($G(ARY("LEX")),"^",2)),1:"")

 . . S PRE="LEX*"_VER_"*"_+($P($G(ARY("LEX")),"^",3))_"^"_$S($P($G(ARY("LEX")),"^",4)?7N:$$FMTE^XLFDT($P($G(ARY("LEX")),"^",4)),1:"")

 . . S ARY("LEX","1")=AFT_"^"_PRE

 Q

 ; 

XMA(LEX) ;   Message Address

 N DIC,DTOUT,DUOUT,X,Y S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="FO-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX

 S DIC="^DIC(4.2,",DIC(0)="M",(LEX,X)="ISC-SLC.DOMAIN.EXT" D ^DIC Q:+Y>0 LEX

 Q "ISC-SLC.DOMAIN.EXT"

BL ;   Blank Line

 W !

 Q

PB(X) ;   Preceeding Blank Line

 S X=$G(X) Q:'$L(X)  W !!,X

 Q

TL(X) ;   Text Line

 W !,$G(X)

 Q

UNIN ; Uninstall from Package

 N LEXREVS,LEXSAB K LEXREVS D REVS^LEXXGU2(.LEXREVS) F LEXSAB="ICD","CPT","LEX" D

 . N DA,DIK,LEXBLD,LEXDA,LEXMSG,LEXND,LEXNS,LEXOUT,LEXPI,LEXPN,LEXRI,LEXRV,LEXSCR,LEXVD,LEXVI,LEXVR

 . S LEXBLD=$P($G(LEXREVS(LEXSAB,1)),"^",1),LEXNS=$$PKG^XPDUTL(LEXBLD) Q:$L(LEXNS)<2!($L(LEXNS)>4)

 . S LEXVR=$$VER^XPDUTL(LEXBLD) Q:+LEXVR'>0  S (LEXPN,LEXRV)=$P(LEXBLD,"*",3) Q:LEXPN'>0

 . S LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""

 . D FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")

 . S LEXPI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG Q:+LEXPI'>0  Q:'$D(@("^DIC(9.4,"_LEXPI_",22)"))

 . K DA S DA(1)=LEXPI S LEXDA=$$IENS^DILF(.DA) D FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")

 . S LEXVI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG Q:+LEXVI'>0  Q:'$D(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")"))

 . K DA S DA(2)=LEXPI,DA(1)=LEXVI S LEXDA=$$IENS^DILF(.DA) S LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""

 . D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")

 . S LEXRI=$G(LEXOUT("DILIST",2,1)) I +LEXRI'>0 S LEXSCR="" D

 . . D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG") S LEXRI=$G(LEXOUT("DILIST",2,1))

 . Q:+LEXRI'>0  S LEXND="^DIC(9.4,"_+LEXPI_",22,"_+LEXVI_",""PAH"","_+LEXRI_",0)"

 . K DA S DIK="^DIC(9.4,"_+LEXPI_",22,"_+LEXVI_",""PAH"",",DA(2)=LEXPI,DA(1)=LEXVI,DA=LEXRI

 . D:$D(@LEXND) ^DIK

 Q

INSD(X)  ;   Installed on

 N DA,LEX,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVD,LEXVI,LEXVR S LEX=$G(X)

 S LEXNS=$$PKG^XPDUTL(LEX),LEXVR=$$VER^XPDUTL(LEX),LEXPN=$P(X,"*",3)

 Q:'$L(LEXNS) ""  S LEXVR=+LEXVR Q:LEXVR'>0 ""  S LEXPN=+LEXPN S:LEXVR'["." LEXVR=LEXVR_".0"

 S LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""

 D FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")

 S LEXPI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG Q:+LEXPI'>0 ""  Q:'$D(@("^DIC(9.4,"_LEXPI_",22)")) ""

 K DA S DA(1)=LEXPI S LEXDA=$$IENS^DILF(.DA)

 D FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")

 S LEXVD=$G(LEXOUT("DILIST","ID",1,2)) I $E(LEXVD,1,7)?7N&(+LEXPN'>0) D  Q X

 . S X=$E(LEXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(LEXVD,1,7),"5DZ"),"@"," ")

 S:$E(LEXVD,1,7)'?7N LEXVD=$G(LEXOUT("DILIST","ID",1,1)) I $E(LEXVD,1,7)?7N&(+LEXPN'>0) D  Q X

 . S X=$E(LEXVD,1,7)_"^"_$TR($$FMTE^XLFDT($E(LEXVD,1,7),"5DZ"),"@"," ")

 Q:+LEXPN'>0 ""  S LEXVI=$G(LEXOUT("DILIST",2,1)) K LEXOUT,LEXMSG

 Q:+LEXVI'>0 ""  Q:'$D(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")")) ""

 K DA S DA(2)=LEXPI,DA(1)=LEXVI S LEXDA=$$IENS^DILF(.DA)

 S LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""

 D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")

 S LEXI=$G(LEXOUT("DILIST","ID",1,.02)) I '$L(LEXI) D

 . S LEXSCR="" D FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")

 . S LEXI=$G(LEXOUT("DILIST","ID",1,.02))

 Q:'$L(LEXI) ""  Q:$P(LEXI,".",1)'?7N ""  S LEXE=$TR($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")

 Q:'$L(LEXE) ""  S X=LEXI_"^"_LEXE

 Q X

MIX(X) ;   Mixed Case

 S X=$G(X) N LEXT,LEXI S LEXT=""

 F LEXI=1:1:$L(X," ") S LEXT=LEXT_" "_$$UP($E($P(X," ",LEXI),1))_$$LO($E($P(X," ",LEXI),2,$L($P(X," ",LEXI))))

 F  Q:$E(LEXT,1)'=" "  S LEXT=$E(LEXT,2,$L(LEXT))

 S:$E(LEXT,1,3)="Cpt" LEXT="CPT"_$E(LEXT,4,$L(LEXT)) S:$E(LEXT,1,3)="Icd" LEXT="ICD"_$E(LEXT,4,$L(LEXT)) S X=LEXT

 Q X

UP(X) ;   Uppercase

 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

LO(X) ;   Lowercase

 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEXXGU2   12826     printed  Mar 13, 2025@21:14:49                                                                                                                                                                                                    Page 2

LEXXGU2   ;ISL/KER - Global Uninstall (^LEXU) ;05/23/2017

 +1       ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^LEXU               N/A

 +5       ;    ^TMP("LEXXGUM")     SACC 2.3.2.5.1

 +6       ;               

 +7       ; External References

 +8       ;    $$S^%ZTLOAD         ICR  10063

 +9       ;    ^DIC                ICR  10006

 +10      ;    FIND^DIC            ICR   2051

 +11      ;    ^DIK                ICR  10013

 +12      ;    $$IENS^DILF         ICR   2054

 +13      ;    $$GET1^DIQ          ICR   2056

 +14      ;    ^DIR                ICR  10026

 +15      ;    $$DT^XLFDT          ICR  10103

 +16      ;    $$FMTE^XLFDT        ICR  10103

 +17      ;    ^XMD                ICR  10070

 +18      ;    $$PKG^XPDUTL        ICR  10141

 +19      ;    $$VERSION^XPDUTL    ICR  10141

 +20      ;    $$VER^XPDUTL        ICR  10141

 +21      ;               

 +22      ; Local Variables NEWed or KILLed Elsewhere

 +23      ;     LEXUNDO            NEWed in LEXXGU

 +24      ;  

FILES     ;   Load Data for all files

 +1        if '$LENGTH($GET(LEXB))

               SET LEXB=$GET(LEXBLD)

           if '$LENGTH($GET(LEXB))

               SET LEXB=$GET(^LEXU(0,"BUILD"))

           if '$LENGTH($GET(LEXB))

               QUIT 

 +2        NEW LEXHDR,LEXBLD,LEXDAT,LEXFI,LEXFIC,LEXINS,LEXTOTI,LEXTOTN,LEXPER,LEXPRE,LEXOK

 +3        SET (LEXFI,LEXFIC,LEXHDR,LEXTOTI,LEXTOTN,LEXPER,LEXPRE)=0

           SET LEXBLD=LEXB

           SET LEXOK=1

 +4        SET LEXDAT=$PIECE($GET(^LEXU(0,"VRRVDT")),"^",1)

           SET LEXINS=1

 +5        if +LEXDAT'>0

               SET LEXDAT=$$DT^XLFDT

           IF LEXOK

               Begin DoDot:1

 +6                NEW LEXCRE,LEXL1

                   SET LEXL1=""

                   SET LEXCRE=$GET(^LEXU(0,"CREATED"))

                   SET LEXCRE=$SELECT(+LEXCRE>0:($$MIX($$FMTE^XLFDT(LEXCRE))),1:"")

 +7                if $LENGTH($PIECE(LEXCRE,"@",2))

                       SET LEXCRE=$PIECE(LEXCRE,"@",1)_" at "_$PIECE(LEXCRE,"@",2)

                   SET LEXL1=" Uninstalling data "

 +8                if $LENGTH($GET(LEXCRE))&($LENGTH($GET(LEXL1)))

                       SET LEXL1=$GET(LEXL1)_"using Undo-Global ^LEXU created "_$GET(LEXCRE)

 +9                DO PB(LEXL1)

               End DoDot:1

 +10       SET LEXFI=0

           FOR 

               SET LEXFI=$ORDER(^LEXU(LEXFI))

               if +LEXFI=0

                   QUIT 

               SET LEXTOTN=+($GET(LEXTOTN))+($ORDER(^LEXU(LEXFI," "),-1))

 +11       SET LEXFI=0

           FOR 

               SET LEXFI=$ORDER(^LEXU(LEXFI))

               if +LEXFI=0

                   QUIT 

               DO FILE

 +12       QUIT 

FILE      ;     Load Data for one file

 +1        NEW LEXCHG,LEXCNT,LEXFIL,LEXFIR,LEXI,LEXL,LEXLC

 +2        NEW LEXMUMPS,LEXNM,LEXRT,LEXS,LEXTOT,LEXTXT

 +3        SET LEXFIR=$ORDER(^LEXU(($PIECE(LEXFI,".",1)-.000001)))

 +4        SET (LEXCNT,LEXLC,LEXI)=0

           SET LEXL=68

           SET LEXFIC=LEXFIC+1

           IF LEXOK

               Begin DoDot:1

 +5                NEW LEXB,LEXFID,LEXNM,LEXVR,LEXRV,LEXDT,LEXL1

                   SET LEXL1=""

                   SET LEXFID=$PIECE(LEXFI,".",1)

                   if +LEXFID'>0

                       QUIT 

 +6                if LEXFID=80

                       SET LEXNM="ICD Files"

                   if LEXFID=81

                       SET LEXNM="CPT-4/HCPCS"

                   if LEXFID=757

                       SET LEXNM="Lexicon"

                   SET LEXB=$GET(^LEXU(LEXFI,0,"BUILD"))

 +7                SET LEXVR=$GET(^LEXU(LEXFI,0,"VR"))

                   SET LEXRV=$GET(^LEXU(LEXFI,0,"VRRV"))

                   SET LEXDT=$$MIX($$FMTE^XLFDT($PIECE(LEXRV,"^",2)))

                   SET LEXRV=$PIECE(LEXRV,"^",1)

 +8                if '$LENGTH(LEXNM)

                       QUIT 

                   SET LEXL1="Uninstalling data for "_LEXNM

                   SET LEXL1=" "_LEXL1

                   if LEXFI=LEXFIR

                       DO BL

                       DO TL(LEXL1)

                   if $GET(LEXNM)'["ICD F"

                       DO BL

               End DoDot:1

 +9        SET LEXTOT=+($GET(^LEXU(LEXFI,0)))

           if LEXTOT=0

               GOTO FILEQ

 +10       SET LEXNM=$GET(^LEXU(LEXFI,0,"NM"))

 +11       IF $LENGTH(LEXNM)

               IF $$UP(LEXNM)'["FILE"

                   SET LEXNM=LEXNM_" FILE"

 +12       if $LENGTH(LEXNM)

               SET LEXNM=$$MIX(LEXNM)

           SET LEXCHG=$GET(^LEXU(LEXFI,0))

 +13       SET LEXTXT="   "_LEXNM

           SET LEXTXT=LEXTXT_$JUSTIFY("",(40-$LENGTH(LEXTXT)))_LEXFI

 +14       if LEXFIC=1

               DO PB(LEXTXT)

           if LEXFIC'=1

               DO TL(LEXTXT)

 +15       SET LEXS=+(LEXTOT\LEXL)

           if LEXS=0

               SET LEXS=1

           if +($ORDER(^LEXU(LEXFI,0)))>0

               WRITE !,"   "

 +16       FOR 

               SET LEXI=$ORDER(^LEXU(LEXFI,LEXI))

               if +LEXI=0

                   QUIT 

               Begin DoDot:1

 +17               SET LEXCNT=LEXCNT+1

                   SET LEXMUMPS=$GET(^LEXU(LEXFI,LEXI))

 +18               IF LEXCNT'<LEXS

                       SET LEXLC=LEXLC+1

                       if LEXLC'>LEXL

                           WRITE "."

                       SET LEXCNT=0

 +19               SET LEXRT=$PIECE(LEXMUMPS,"^",2)

                   SET LEXFIL=""

 +20               if LEXMUMPS["^LEX("!(LEXMUMPS["^LEXT(")!(LEXMUMPS["^LEXC(")

                       SET LEXFIL=+($PIECE(LEXRT,"(",2))

 +21               if LEXMUMPS["^ICD9("

                       SET LEXFIL=80

                   if LEXMUMPS["^ICD0("

                       SET LEXFIL=80.1

                   if LEXMUMPS["^ICPT("

                       SET LEXFIL=81

 +22               if LEXMUMPS["^DIC(81.1"

                       SET LEXFIL=81.1

                   if LEXMUMPS["^DIC(81.2"

                       SET LEXFIL=81.2

                   if LEXMUMPS["^DIC(81.3"

                       SET LEXFIL=81.3

 +23               IF $LENGTH(LEXMUMPS)

                       Begin DoDot:2

 +24                       XECUTE LEXMUMPS

                           SET LEXUNDO=1

                           SET LEXTOTI=+($GET(LEXTOTI))+1

                           IF +($GET(LEXTOTN))>0

                               IF +($GET(LEXTOTI))>0

                                   IF $DATA(ZTQUEUED)

                                       IF +($GET(ZTSK))>0

                                           Begin DoDot:3

 +25                                           NEW LEXT,LEXTSK

                                               SET (LEXT,LEXPER)=(+($GET(LEXTOTI))/+($GET(LEXTOTN)))*100

                                               if +LEXPER-(+($GET(LEXPRE)))'>2

                                                   QUIT 

                                               SET LEXPRE=+($GET(LEXPER))

 +26                                           SET LEXPER=$JUSTIFY(LEXPER,6,2)

                                               IF +LEXT>0

                                                   SET LEXPER=LEXPER_"% complete"

                                                   SET LEXTSK=$$S^%ZTLOAD(LEXPER)

 +27                                           NEW ZTQUEUED,ZTSK

                                           End DoDot:3

                       End DoDot:2

               End DoDot:1

FILEQ     ;     Load Data for one file - QUIT

 +1        QUIT 

 +2       ; 

CHK(X)    ; Check Versions

 +1        NEW DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,CHK,AFT,PRE,AEF,PEF,REV,BLD

           KILL CHK

           DO REVS(.CHK)

           SET BLD=$PIECE($GET(CHK("LEXU",1)),"^",1)

 +2        IF +($GET(CHK("LEXU")))'>0

               WRITE !!,"   Undo-Global ^LEXU Build not found",!

               QUIT 0

 +3        IF +($GET(CHK("LEXU")))'=+($GET(CHK("LEX")))

               WRITE !!,"   Undo-Global ^LEXU Build is invalid",!

               QUIT 0

 +4        IF '$DATA(CHK("LEX"))&('$DATA(CHK("CPT")))&('$DATA(CHK("ICD")))

               WRITE !!,"   Current/Past Builds not found",!

               QUIT 0

 +5        SET AFT=$PIECE($GET(CHK("LEX")),"^",1)

           SET PRE=$PIECE($GET(CHK("LEX")),"^",3)

 +6        IF AFT'>0!(PRE'>0)!(AFT'>PRE)

               Begin DoDot:1

 +7                WRITE !!,"   Current/Past Builds are invalid",!

               End DoDot:1

               QUIT 0

 +8        SET REV=$GET(CHK("LEX",1))

           SET AFT=$PIECE(REV,"^",1)

           SET AEF=$PIECE(REV,"^",2)

           SET PRE=$PIECE(REV,"^",3)

           SET PEF=$PIECE(REV,"^",4)

 +9        IF '$LENGTH(REV)!('$LENGTH(AFT))!('$LENGTH(AEF))!('$LENGTH(PRE))!('$LENGTH(PEF))

               WRITE !!,"   Primary Build not found",!

               QUIT 0

 +10       IF $DATA(TEST)

               WRITE !!," Uninstall"

               if $LENGTH($GET(BLD))

                   WRITE " Patch ",BLD

               WRITE ":"

 +11       WRITE !!,"   Uninstall Build",?36,"Revert to"

 +12       WRITE !,"   --------------------------",?36,"--------------------------"

 +13       WRITE !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF

 +14       SET REV=$GET(CHK("ICD",1))

           SET AFT=$PIECE(REV,"^",1)

           SET AEF=$PIECE(REV,"^",2)

           SET PRE=$PIECE(REV,"^",3)

           SET PEF=$PIECE(REV,"^",4)

 +15       IF $LENGTH(AFT)

               IF $LENGTH(AEF)

                   IF $LENGTH(PRE)

                       IF $LENGTH(PEF)

                           WRITE !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF

 +16       SET REV=$GET(CHK("CPT",1))

           SET AFT=$PIECE(REV,"^",1)

           SET AEF=$PIECE(REV,"^",2)

           SET PRE=$PIECE(REV,"^",3)

           SET PEF=$PIECE(REV,"^",4)

 +17       IF $LENGTH(AFT)

               IF $LENGTH(AEF)

                   IF $LENGTH(PRE)

                       IF $LENGTH(PEF)

                           WRITE !,"   ",AFT,?17,AEF,?36,PRE,?50,PEF