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 ---[H[J[2J[HLEXXGU2 12826 printed Oct 16, 2024@18:11:01 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
+18 if $LENGTH(BLD)
SET DIR("A")=" Uninstall patch "_BLD_" (Y/N): "
if '$LENGTH(BLD)
SET DIR("A")=" Uninstall patch (Y/N): "
+19 SET DIR("B")="NO"
SET DIR(0)="YAO"
WRITE !
DO ^DIR
SET X=+Y
if "^1^0^"'[("^"_Y_"^")
SET X="^"
NEW TEST
+20 QUIT X
+21 ;
+22 ; Miscellaneous
MAIL ; Mail Message
+1 if '$DATA(^TMP("LEXXGUM",$JOB))
QUIT
if '$LENGTH($GET(LEXSUB))
QUIT
NEW XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,LEXJ,LEXNM
+2 SET XMTEXT="^TMP(""LEXXGUM"","_$JOB_","
SET XMSUB=$GET(LEXSUB)
SET LEXNM=$$GET1^DIQ(200,+($GET(DUZ)),.01)
SET XMY(("G.LEXINS@"_$$XMA))=""
+3 SET XMY(LEXNM)=""
SET XMDUZ=.5
DO ^XMD
IF '$DATA(ZTQUEUED)
IF +($GET(XMZ))>0
Begin DoDot:1
+4 WRITE !!," ",LEXSUB," Message #",($GET(XMZ))," sent"
End DoDot:1
XMSQ ; Send Message (Quit)
+1 KILL ^TMP("LEXXGUM",$JOB),LEXNM,LEXSUB
+2 QUIT
REVS(ARY) ; Revisions
+1 NEW FI,EFF,AFT,PRE,REV,VER
KILL ARY
SET REV=$PIECE($GET(^LEXU(0,"BUILD")),"*",3)
+2 IF $LENGTH(REV)
Begin DoDot:1
+3 NEW EFF
SET ARY("LEXU")=REV
SET VER=$$VERSION^XPDUTL("LEX")
IF $LENGTH($GET(ARY("LEXU")))&(+VER>0)
Begin DoDot:2
End DoDot:2
+4 SET ARY("LEXU","1")="LEX*"_VER_"*"_REV
SET EFF=$PIECE($GET(^LEXU(0,"VRRVDT")),"^",1)
+5 if EFF?7N
SET $PIECE(ARY("LEXU","1"),"^",2)=EFF
End DoDot:1
+6 FOR FI=80,80.1
Begin DoDot:1
+7 if '$DATA(^LEXU(FI))
QUIT
NEW IEN,AFT,PRE
SET AFT=$GET(^LEXU(FI,0,"VRRV"))
SET IEN=$ORDER(^LEXU(FI," "),-1)
+8 SET PRE=$TRANSLATE($PIECE($GET(^LEXU(FI,IEN)),"=",2),"""","")
+9 IF +AFT>0
IF +PRE>0
IF +AFT>++PRE
IF +($PIECE(AFT,"^",2))?7N
Begin DoDot:2
+10 SET ARY("ICD",+($PIECE(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+11 SET EFF=$ORDER(ARY("ICD"," "),-1)
SET AFT=$ORDER(ARY("ICD",+EFF," "),-1)
SET PRE=$ORDER(ARY("ICD",+EFF,+AFT," "),-1)
+12 SET REV=$GET(ARY("ICD",+EFF,+AFT,+PRE))
KILL ARY("ICD")
IF $LENGTH(REV)
Begin DoDot:1
+13 SET ARY("ICD")=REV
SET VER=$$VERSION^XPDUTL("ICD")
IF $LENGTH($GET(ARY("ICD")))&(+VER>0)
Begin DoDot:2
+14 SET AFT="ICD*"_VER_"*"_+($PIECE($GET(ARY("ICD")),"^",1))_"^"_$SELECT($PIECE($GET(ARY("ICD")),"^",2)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("ICD")),"^",2)),1:"")
+15 SET PRE="ICD*"_VER_"*"_+($PIECE($GET(ARY("ICD")),"^",3))_"^"_$SELECT($PIECE($GET(ARY("ICD")),"^",4)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("ICD")),"^",4)),1:"")
+16 SET ARY("ICD","1")=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+17 FOR FI=81,81.1,81.2,81.3
Begin DoDot:1
+18 if '$DATA(^LEXU(FI))
QUIT
NEW IEN,AFT,PRE
SET AFT=$GET(^LEXU(FI,0,"VRRV"))
SET IEN=$ORDER(^LEXU(FI," "),-1)
+19 SET PRE=$TRANSLATE($PIECE($GET(^LEXU(FI,IEN)),"=",2),"""","")
+20 IF +AFT>0
IF +PRE>0
IF +AFT>++PRE
IF +($PIECE(AFT,"^",2))?7N
Begin DoDot:2
+21 SET ARY("CPT",+($PIECE(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+22 SET EFF=$ORDER(ARY("CPT"," "),-1)
SET AFT=$ORDER(ARY("CPT",+EFF," "),-1)
SET PRE=$ORDER(ARY("CPT",+EFF,+AFT," "),-1)
+23 SET REV=$GET(ARY("CPT",+EFF,+AFT,+PRE))
KILL ARY("CPT")
IF $LENGTH(REV)
Begin DoDot:1
+24 SET ARY("CPT")=REV
SET VER=$$VERSION^XPDUTL("ICPT")
IF $LENGTH($GET(ARY("CPT")))&(+VER>0)
Begin DoDot:2
+25 SET AFT="ICPT*"_VER_"*"_+($PIECE($GET(ARY("CPT")),"^",1))_"^"_$SELECT($PIECE($GET(ARY("CPT")),"^",2)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("CPT")),"^",2)),1:"")
+26 SET PRE="ICPT*"_VER_"*"_+($PIECE($GET(ARY("CPT")),"^",3))_"^"_$SELECT($PIECE($GET(ARY("CPT")),"^",4)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("CPT")),"^",4)),1:"")
+27 SET ARY("CPT","1")=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+28 SET FI=756.9999
FOR
SET FI=$ORDER(@("^DIC("_+FI_")"))
if +FI'>0!($PIECE(FI,".",1)'=757)!(FI>757.41)
QUIT
Begin DoDot:1
+29 if '$DATA(^LEXU(FI))
QUIT
NEW IEN,AFT,PRE
SET AFT=$GET(^LEXU(FI,0,"VRRV"))
SET IEN=$ORDER(^LEXU(FI," "),-1)
+30 SET PRE=$TRANSLATE($PIECE($GET(^LEXU(FI,IEN)),"=",2),"""","")
IF +AFT>0
IF +PRE>0
IF +AFT>++PRE
IF +($PIECE(AFT,"^",2))?7N
Begin DoDot:2
+31 SET ARY("LEX",+($PIECE(AFT,"^",2)),+AFT,+PRE)=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+32 SET EFF=$ORDER(ARY("LEX"," "),-1)
SET AFT=$ORDER(ARY("LEX",+EFF," "),-1)
SET PRE=$ORDER(ARY("LEX",+EFF,+AFT," "),-1)
+33 SET REV=$GET(ARY("LEX",+EFF,+AFT,+PRE))
KILL ARY("LEX")
IF $LENGTH(REV)
Begin DoDot:1
+34 SET ARY("LEX")=REV
SET VER=$$VERSION^XPDUTL("LEX")
IF $LENGTH($GET(ARY("LEX")))&(+VER>0)
Begin DoDot:2
+35 SET AFT="LEX*"_VER_"*"_+($PIECE($GET(ARY("LEX")),"^",1))_"^"_$SELECT($PIECE($GET(ARY("LEX")),"^",2)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("LEX")),"^",2)),1:"")
+36 SET PRE="LEX*"_VER_"*"_+($PIECE($GET(ARY("LEX")),"^",3))_"^"_$SELECT($PIECE($GET(ARY("LEX")),"^",4)?7N:$$FMTE^XLFDT($PIECE($GET(ARY("LEX")),"^",4)),1:"")
+37 SET ARY("LEX","1")=AFT_"^"_PRE
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
XMA(LEX) ; Message Address
+1 NEW DIC,DTOUT,DUOUT,X,Y
SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="FO-SLC.DOMAIN.EXT"
DO ^DIC
if +Y>0
QUIT LEX
+2 SET DIC="^DIC(4.2,"
SET DIC(0)="M"
SET (LEX,X)="ISC-SLC.DOMAIN.EXT"
DO ^DIC
if +Y>0
QUIT LEX
+3 QUIT "ISC-SLC.DOMAIN.EXT"
BL ; Blank Line
+1 WRITE !
+2 QUIT
PB(X) ; Preceeding Blank Line
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT
WRITE !!,X
+2 QUIT
TL(X) ; Text Line
+1 WRITE !,$GET(X)
+2 QUIT
UNIN ; Uninstall from Package
+1 NEW LEXREVS,LEXSAB
KILL LEXREVS
DO REVS^LEXXGU2(.LEXREVS)
FOR LEXSAB="ICD","CPT","LEX"
Begin DoDot:1
+2 NEW DA,DIK,LEXBLD,LEXDA,LEXMSG,LEXND,LEXNS,LEXOUT,LEXPI,LEXPN,LEXRI,LEXRV,LEXSCR,LEXVD,LEXVI,LEXVR
+3 SET LEXBLD=$PIECE($GET(LEXREVS(LEXSAB,1)),"^",1)
SET LEXNS=$$PKG^XPDUTL(LEXBLD)
if $LENGTH(LEXNS)<2!($LENGTH(LEXNS)>4)
QUIT
+4 SET LEXVR=$$VER^XPDUTL(LEXBLD)
if +LEXVR'>0
QUIT
SET (LEXPN,LEXRV)=$PIECE(LEXBLD,"*",3)
if LEXPN'>0
QUIT
+5 SET LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""
+6 DO FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")
+7 SET LEXPI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
if +LEXPI'>0
QUIT
if '$DATA(@("^DIC(9.4,"_LEXPI_",22)"))
QUIT
+8 KILL DA
SET DA(1)=LEXPI
SET LEXDA=$$IENS^DILF(.DA)
DO FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
+9 SET LEXVI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
if +LEXVI'>0
QUIT
if '$DATA(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")"))
QUIT
+10 KILL DA
SET DA(2)=LEXPI
SET DA(1)=LEXVI
SET LEXDA=$$IENS^DILF(.DA)
SET LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+11 DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+12 SET LEXRI=$GET(LEXOUT("DILIST",2,1))
IF +LEXRI'>0
SET LEXSCR=""
Begin DoDot:2
+13 DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
SET LEXRI=$GET(LEXOUT("DILIST",2,1))
End DoDot:2
+14 if +LEXRI'>0
QUIT
SET LEXND="^DIC(9.4,"_+LEXPI_",22,"_+LEXVI_",""PAH"","_+LEXRI_",0)"
+15 KILL DA
SET DIK="^DIC(9.4,"_+LEXPI_",22,"_+LEXVI_",""PAH"","
SET DA(2)=LEXPI
SET DA(1)=LEXVI
SET DA=LEXRI
+16 if $DATA(@LEXND)
DO ^DIK
End DoDot:1
+17 QUIT
INSD(X) ; Installed on
+1 NEW DA,LEX,LEXDA,LEXE,LEXI,LEXMSG,LEXNS,LEXOUT,LEXPI,LEXPN,LEXSCR,LEXVI,LEXVD,LEXVI,LEXVR
SET LEX=$GET(X)
+2 SET LEXNS=$$PKG^XPDUTL(LEX)
SET LEXVR=$$VER^XPDUTL(LEX)
SET LEXPN=$PIECE(X,"*",3)
+3 if '$LENGTH(LEXNS)
QUIT ""
SET LEXVR=+LEXVR
if LEXVR'>0
QUIT ""
SET LEXPN=+LEXPN
if LEXVR'["."
SET LEXVR=LEXVR_".0"
+4 SET LEXSCR="I $G(^DIC(9.4,+($G(Y)),""VERSION""))="""_LEXVR_""""
+5 DO FIND^DIC(9.4,,.01,"O",LEXNS,10,"C",LEXSCR,,"LEXOUT","LEXMSG")
+6 SET LEXPI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
if +LEXPI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_LEXPI_",22)"))
QUIT ""
+7 KILL DA
SET DA(1)=LEXPI
SET LEXDA=$$IENS^DILF(.DA)
+8 DO FIND^DIC(9.49,LEXDA,".01;1I;2I","O",LEXVR,10,"B",,,"LEXOUT","LEXMSG")
+9 SET LEXVD=$GET(LEXOUT("DILIST","ID",1,2))
IF $EXTRACT(LEXVD,1,7)?7N&(+LEXPN'>0)
Begin DoDot:1
+10 SET X=$EXTRACT(LEXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(LEXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+11 if $EXTRACT(LEXVD,1,7)'?7N
SET LEXVD=$GET(LEXOUT("DILIST","ID",1,1))
IF $EXTRACT(LEXVD,1,7)?7N&(+LEXPN'>0)
Begin DoDot:1
+12 SET X=$EXTRACT(LEXVD,1,7)_"^"_$TRANSLATE($$FMTE^XLFDT($EXTRACT(LEXVD,1,7),"5DZ"),"@"," ")
End DoDot:1
QUIT X
+13 if +LEXPN'>0
QUIT ""
SET LEXVI=$GET(LEXOUT("DILIST",2,1))
KILL LEXOUT,LEXMSG
+14 if +LEXVI'>0
QUIT ""
if '$DATA(@("^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"")"))
QUIT ""
+15 KILL DA
SET DA(2)=LEXPI
SET DA(1)=LEXVI
SET LEXDA=$$IENS^DILF(.DA)
+16 SET LEXSCR="I $G(^DIC(9.4,"_LEXPI_",22,"_LEXVI_",""PAH"",+($G(Y)),0))[""SEQ #"""
+17 DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+18 SET LEXI=$GET(LEXOUT("DILIST","ID",1,.02))
IF '$LENGTH(LEXI)
Begin DoDot:1
+19 SET LEXSCR=""
DO FIND^DIC(9.4901,LEXDA,".01;.02I",,LEXPN,10,"B",LEXSCR,,"LEXOUT","LEXMSG")
+20 SET LEXI=$GET(LEXOUT("DILIST","ID",1,.02))
End DoDot:1
+21 if '$LENGTH(LEXI)
QUIT ""
if $PIECE(LEXI,".",1)'?7N
QUIT ""
SET LEXE=$TRANSLATE($$FMTE^XLFDT(LEXI,"5DZ"),"@"," ")
+22 if '$LENGTH(LEXE)
QUIT ""
SET X=LEXI_"^"_LEXE
+23 QUIT X
MIX(X) ; Mixed Case
+1 SET X=$GET(X)
NEW LEXT,LEXI
SET LEXT=""
+2 FOR LEXI=1:1:$LENGTH(X," ")
SET LEXT=LEXT_" "_$$UP($EXTRACT($PIECE(X," ",LEXI),1))_$$LO($EXTRACT($PIECE(X," ",LEXI),2,$LENGTH($PIECE(X," ",LEXI))))
+3 FOR
if $EXTRACT(LEXT,1)'=" "
QUIT
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
+4 if $EXTRACT(LEXT,1,3)="Cpt"
SET LEXT="CPT"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
if $EXTRACT(LEXT,1,3)="Icd"
SET LEXT="ICD"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
SET X=LEXT
+5 QUIT X
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LO(X) ; Lowercase
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
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=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
