LEX2049P.m

LEX2049P ; ISL/OI - Post Install LEX*2.0*49  ; 02/22/2007

 ;;2.0;LEXICON UTILITY;**49**;Sep 23, 1996;Build 3

 ;                    

 ; Global Variables

 ;    ^%ZOSF("DEL" 

 ;    ^%ZOSF("TEST"

 ;    ^LEXC

 ;    ^LEXM(0

 ;    ^LEXT(757.2

 ;    ^ORD(101

 ;    ^TMP("LEXCNT"

 ;    ^TMP("LEXCS"

 ;    ^TMP("LEXI"

 ;    ^TMP("LEXINS"

 ;    ^TMP("LEXKID"

 ;    ^TMP("LEXMSG"

 ;                

 ; External References

 ;    HOME^%ZIS

 ;    $$GET1^DID

 ;    ^DIK

 ;    ^DIM

 ;    $$GET1^DIQ

 ;    EN^DIU2

 ;    $$DT^XLFDT

 ;    $$FMTE^XLFDT

 ;    $$NOW^XLFDT

 ;    BMES^XPDUTL

 ;    MES^XPDUTL

 ;    EN^XQOR

 ;    $$DTIME^XUP

 ;                        

POST ; Post-Install Main Entry Point

 N CNT,DA,DIK,DIU,ERR,EXEC,FI,FIX,FNAME,I,INST,LEX,LEXBEG,LEXBUILD,LEXCHG,LEXEDT,LEXELP,LEXEND

 N LEXFC,LEXI,LEXID,LEXMOD,LEXMUL,LEXNM,LEXO,LEXP,LEXPOST,LEXSCHG,LEXSHORT,LEXSUB,LEXTCS,LEXTND

 N NAME,OK,PN,PNO,ROK,RTN,SSIEN,STR,T,TAG,TXT,TY,X,Y,ZTQUEUED,ZTREQ S LEXPOST="",LEXSHORT="",(LEXID,LEXSUB)="LEXKID" D MSG1

 S LEXCHG=1,LEXEDT=$$NOW^XLFDT,LEXSCHG("0")="1"

 S LEXSCHG("81",0)="",LEXSCHG("81.1",0)="",LEXSCHG("81.2",0)="",LEXSCHG("81.3",0)=""

 S LEXSCHG("B","81")="",LEXSCHG("B","81.1")="",LEXSCHG("B","81.2")="",LEXSCHG("B","81.3")=""

 S LEXSCHG("C","CPT","81")="",LEXSCHG("C","CPT","81.1")="",LEXSCHG("C","CPT","81.2")="",LEXSCHG("C","CPT","81.3")=""

 S LEXSCHG("80",0)="",LEXSCHG("80.1",0)=""

 S LEXSCHG("B","80")="",LEXSCHG("B","80.1")=""

 S LEXSCHG("C","ICD","80")="",LEXSCHG("C","ICD","80.1")=""

 S LEXSCHG("757",0)="",LEXSCHG("757.001",0)="",LEXSCHG("757.01",0)="",LEXSCHG("757.02",0)="",LEXSCHG("757.1",0)=""

 S LEXSCHG("B","757")="",LEXSCHG("B","757.001")="",LEXSCHG("B","757.01")="",LEXSCHG("B","757.02")="",LEXSCHG("B","757.1")=""

 S LEXSCHG("C","LEX","757")="",LEXSCHG("C","LEX","757.001")="",LEXSCHG("C","LEX","757.01")="",LEXSCHG("C","LEX","757.02")="",LEXSCHG("C","LEX","757.1")=""

 S LEXSCHG("D","PRO")="",LEXSHORT=""

 D DDUZ,CHGF,RTN,INST,NOTIFY,MSG2,KALL^LEXXGI2

 Q

INST ; Installed Patches

 N INST,STR D BL

 S INST=$$PROK("PXRMCSD",9) S STR=" PXRM*2.0*9      "_$S(INST>0:"Installed",1:"Not Installed") D BM(STR),TL(STR)

 S INST=$$PROK("ICDUPDT",28) S STR=" ICD*18.0*28     "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)

 S INST=$$PROK("ICPTAU",34) S STR=" ICPT*6.0*34     "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)

 S INST=$$PROK("LEXXGI",49) S STR=" LEX*2.0*49      "_$S(INST>0:"Installed",1:"Not Installed") D M(STR),TL(STR)

 Q

NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE

 N LEXP,X,STR

 S STR="ERROR:  Array of files not found" D:'$D(LEXSCHG) BM(STR),BL,TL(STR) Q:'$D(LEXSCHG)

 S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))

 S STR="ERROR:  LEXICAL SERVICES UPDATE protocol not found" D:$G(LEXP)'>0 BM(STR),BL,TL(STR) Q:LEXP=0

 S X=LEXP_";ORD(101," D EN^XQOR

 S STR="ERROR:  LEXICAL SERVICES UPDATE protocol not invoked" D:$D(LEXSCHG) BM(STR),BL,TL(STR) Q:$D(LEXSCHG)

 S ^LEXM(0,"PRO")=$$NOW^XLFDT,X="Protocol 'LEXICAL SERVICES UPDATE' was invoked"

 W:'$D(XPDNM) !!,X D:$D(XPDNM) BM(X)

 S (STR,X)="Subscribing applications were notified",STR="  "_STR D BL,TL(STR)

 W:'$D(XPDNM) !,X D:$D(XPDNM) M(X)

 Q

CHGF ; Change File

 D M(" "),RI("Removing Change Files (757.9-757.91)","Remedy 175985") N FI,FNAME,ERR,ROK,STR

 S FI=757.91,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D

 . N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)

 S FI=757.903,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D

 . N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)

 S FI=757.9,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D

 . N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)

 S FI=757.901,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D

 . N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)

 S FI=757.902,FNAME=$$GET1^DID(FI,"","","NAME","","ERR") I $L(FNAME) D

 . N DIU,ERR S DIU="^LEXC("_FI_",",DIU(0)="D" D EN^DIU2 K:'$L($$GET1^DID(FI,"","","NAME","","ERR")) ^LEXC(FI)

 I '$D(^LEXC) S STR="Removed Change Files (757.9-757.91) (Remedy 175985)" D BL,TL(STR)     Q

 Q

RTN ; Routines

 D M(" "),BL D DRTN,MRTN

 Q

DRTN ; Delete Routines

 N EXEC,ROK,RTN,STR,X

 S X=$G(^%ZOSF("DEL")) Q:'$L(X)  D ^DIM Q:'$D(X)  Q:'$L(X)  S EXEC=X

 F RTN="LEXCHGF","LEXCHGF2","LEXNDX7","LEXXST5" D

 . S ROK=+($$ROK(RTN)) I +ROK'>0 S STR="    "_RTN,STR=STR_$J(" ",(17-$L(STR)))_"Deleted" D M(STR),TL(STR) Q

 . S X=RTN X EXEC

 . S ROK=+($$ROK(RTN)) I +ROK'>0 S STR="    "_RTN,STR=STR_$J(" ",(17-$L(STR)))_"Deleted" D M(STR),TL(STR) Q

 . S STR="    "_RTN D M(STR),TL(STR)

 Q

MRTN ; Modified Routines

 N CNT,EXEC,FIX,I,RTN,PN,PNO,STR,TXT,TY S CNT=0 F I=1:1 D  Q:'$L(TXT)

 . S TXT="" S EXEC="S TXT=$T(MRN+"_I_"^LEX2049P)" X EXEC

 . S TXT=$P(TXT,";;",2,299) Q:TXT=""

 . S RTN=$P(TXT,";",1) S:'$L(RTN) TXT="" Q:'$L(TXT)  Q:+($$ROK(RTN))=0

 . S PN=$P(TXT,";",2),TY=$P(TXT,";",3),FIX=$P(TXT,";",4)

 . S PNO=$$PROK(RTN,PN)

 . S STR="    "_RTN S:+PNO>0 STR=STR_$J(" ",(17-$L(STR)))_TY S:+PNO>0 STR=STR_$J(" ",(29-$L(STR)))_FIX

 . D M(STR),TL(STR)

 Q

MRN ; Modified Routine Names

 ;;LEXXFI;49;Modified;Removed references to file #757.9

 ;;LEXXFI7;49;Modified;Removed references to file #757.9

 ;;LEXXST;49;Modified;Removed references to file #757.9

 ;;LEXXGI;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol

 ;;LEXXGI2;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol

 ;;LEXXII;49;Modified;Fix Install Message (Protocol)

 ;;ICDUPDT;28;Modified;Fix ICD CODE UPDATE EVENT Protocol

 ;;ICPTAU;34;Modified;Fix ICPT CODE UPDATE EVENT Protocol

 ;;PXRMCSD;9;Modified;Fix ICD/CPT Reminder Dialogs Message

 ;;PXRMCSTX;9;Modified;Fix ICD/CPT Reminder Taxonomies Message

 ;;

DDUZ ; Delete Exported DUZ if broken Pointer

 N STR S STR="Removing broken Pointer in file #757.2"

 D M(" "),RI(STR,"ROF LEX*2.0*46") S STR=STR_" (ROF LEX*2.0*46)" Q:$L($$GET1^DIQ(200,("1118,"),.01))

 D BL,TL(STR) N DA,DIK,NAME,SSIEN S SSIEN=0 F  S SSIEN=$O(^LEXT(757.2,SSIEN)) Q:+SSIEN'>0  D

 . Q:'$D(^LEXT(757.2,SSIEN,200))  Q:$O(^LEXT(757.2,SSIEN,200,0))'>0  Q:'$D(^LEXT(757.2,SSIEN,200,1118))

 . N DA,DIK,NAME S NAME=$P($G(^LEXT(757.2,SSIEN,0)),"^",1) D:$L(NAME) CI(("  "_NAME))

 . S DA(1)=SSIEN,DA=1118,DIK="^LEXT(757.2,"_SSIEN_",200," D ^DIK

 Q

ROK(X) ; Routine OK

 S X=$G(X) Q:'$L(X) 0  Q:$L(X)>8 0  X ^%ZOSF("TEST") Q:$T 1  Q 0

PROK(X,Y) ; Routine and Patch # OK (in UCI)

 N LEX,LEXI,LEXO S X=$G(X),Y=$G(Y) Q:'$L(X) 0 Q:Y'=""&(+Y=0)

 S Y=+Y,LEX=$$ROK(X) Q:'LEX 0 Q:+Y=0 1 S LEXO=0,LEX=$T(@("+2^"_X)),LEX=$P($P(LEX,"**",2),"**",1)

 F LEXI=1:1:$L(LEX,",") S:+($P(LEX,",",LEXI))=Y LEXO=1 Q:LEXO=1

 S X=LEXO

 Q X

LL(T,X) ; Line Label

 N RTN,TAG,ROK,EXEC,OK S TAG=$G(T),RTN=$G(X) Q:'$L(RTN) 0  S ROK=$$ROK(RTN) Q:+ROK'>0 0  S:'$L(TAG)&($L(RTN)) TAG=RTN

 S OK=0,EXEC="S OK=$L($T("_TAG_"^"_RTN_")) S OK=$S(OK>0:1,1:0)" X EXEC S X=+($G(OK))

 Q X

MSG1 ; Send Installation Message to G.LEXICON

 K ^TMP("LEXCS",$J),^TMP("LEXCNT",$J),^TMP("LEXI",$J),^TMP("LEXMSG",$J)

 K ^TMP("LEXINS",$J),^TMP("LEXKID",$J) S:$D(ZTQUEUED) ZTREQ="@"

 N LEXBEG,LEXELP,LEXEND,LEXFC,LEXMOD,LEXMUL,LEXTCS,LEXTND,LEXID,ZTQUEUED

 S LEXID="LEXKID",LEXMUL=1,(LEXTND,LEXTCS,LEXMOD,LEXFC,ZTQUEUED)=0

 D HDR^LEXXFI,EN^LEXXII K ^LEXM(0,"PRO")

 Q

MSG2 ; Send Installation (part 2)

 N LEXSHORT,ZTQUEUED,LEXBUILD S ZTQUEUED=0,LEXSHORT=1,LEXBUILD="LEX*2.0*49"

 D MAIL^LEXXFI,KILL^LEXXFI

 Q

ENV(X) ; Environment check

 N LEXNM D HOME^%ZIS S U="^",DT=$$DT^XLFDT,LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01),DTIME=$$DTIME^XUP(+($G(DUZ))) Q:+($G(DUZ))'>0!('$L(LEXNM)) 0

 Q 1

ED(LEX) ; External Date MM/DD/YYYY TT:TT

 N XPDNM S LEX=$$FMTE^XLFDT($G(LEX),"1Z") S:LEX["@" LEX=$P(LEX,"@",1)_"  "_$P(LEX,"@",2,299)

 Q LEX

RI(X,Y) ; Reference - Indented

 N I S X=$G(X),Y=$G(Y) Q:'$L(X)

 I $L(Y) S X="    "_X F  Q:$L(X)>54  S X=X_" "

 S X=X_" "_Y S:$E(X,1)'=" " X="    "_X D MES^XPDUTL(X) Q

CI(X) ; Comment Text - Indented

 N I S X=$G(X) Q:'$L(X)  S X="    "_X D MES^XPDUTL(X)

 Q

BL ;   Blank Line

 D TL("") Q

TL(LEXX) ;   Text Line

 S LEXSUB=$G(LEXSUB) S:'$L(LEXSUB) LEXSUB="LEXXII"

 I '$D(^TMP(LEXSUB,$J,1)) S ^TMP(LEXSUB,$J,1)=" ",^TMP(LEXSUB,$J,0)=1

 N LEXNX S LEXNX=$O(^TMP(LEXSUB,$J," "),-1),LEXNX=LEXNX+1

 S ^TMP(LEXSUB,$J,LEXNX)=" "_$G(LEXX),^TMP(LEXSUB,$J,0)=LEXNX

 Q

BM(X) ; Blank and Line

 D BMES^XPDUTL($G(X))

 Q

M(X) ; Line

 D MES^XPDUTL($G(X))

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEX2049P   8604     printed  Mar 13, 2025@21:08:47                                                                                                                                                                                                    Page 2

LEX2049P  ; ISL/OI - Post Install LEX*2.0*49  ; 02/22/2007

 +1       ;;2.0;LEXICON UTILITY;**49**;Sep 23, 1996;Build 3

 +2       ;                    

 +3       ; Global Variables

 +4       ;    ^%ZOSF("DEL" 

 +5       ;    ^%ZOSF("TEST"

 +6       ;    ^LEXC

 +7       ;    ^LEXM(0

 +8       ;    ^LEXT(757.2

 +9       ;    ^ORD(101

 +10      ;    ^TMP("LEXCNT"

 +11      ;    ^TMP("LEXCS"

 +12      ;    ^TMP("LEXI"

 +13      ;    ^TMP("LEXINS"

 +14      ;    ^TMP("LEXKID"

 +15      ;    ^TMP("LEXMSG"

 +16      ;                

 +17      ; External References

 +18      ;    HOME^%ZIS

 +19      ;    $$GET1^DID

 +20      ;    ^DIK

 +21      ;    ^DIM

 +22      ;    $$GET1^DIQ

 +23      ;    EN^DIU2

 +24      ;    $$DT^XLFDT

 +25      ;    $$FMTE^XLFDT

 +26      ;    $$NOW^XLFDT

 +27      ;    BMES^XPDUTL

 +28      ;    MES^XPDUTL

 +29      ;    EN^XQOR

 +30      ;    $$DTIME^XUP

 +31      ;                        

POST      ; Post-Install Main Entry Point

 +1        NEW CNT,DA,DIK,DIU,ERR,EXEC,FI,FIX,FNAME,I,INST,LEX,LEXBEG,LEXBUILD,LEXCHG,LEXEDT,LEXELP,LEXEND

 +2        NEW LEXFC,LEXI,LEXID,LEXMOD,LEXMUL,LEXNM,LEXO,LEXP,LEXPOST,LEXSCHG,LEXSHORT,LEXSUB,LEXTCS,LEXTND

 +3        NEW NAME,OK,PN,PNO,ROK,RTN,SSIEN,STR,T,TAG,TXT,TY,X,Y,ZTQUEUED,ZTREQ

           SET LEXPOST=""

           SET LEXSHORT=""

           SET (LEXID,LEXSUB)="LEXKID"

           DO MSG1

 +4        SET LEXCHG=1

           SET LEXEDT=$$NOW^XLFDT

           SET LEXSCHG("0")="1"

 +5        SET LEXSCHG("81",0)=""

           SET LEXSCHG("81.1",0)=""

           SET LEXSCHG("81.2",0)=""

           SET LEXSCHG("81.3",0)=""

 +6        SET LEXSCHG("B","81")=""

           SET LEXSCHG("B","81.1")=""

           SET LEXSCHG("B","81.2")=""

           SET LEXSCHG("B","81.3")=""

 +7        SET LEXSCHG("C","CPT","81")=""

           SET LEXSCHG("C","CPT","81.1")=""

           SET LEXSCHG("C","CPT","81.2")=""

           SET LEXSCHG("C","CPT","81.3")=""

 +8        SET LEXSCHG("80",0)=""

           SET LEXSCHG("80.1",0)=""

 +9        SET LEXSCHG("B","80")=""

           SET LEXSCHG("B","80.1")=""

 +10       SET LEXSCHG("C","ICD","80")=""

           SET LEXSCHG("C","ICD","80.1")=""

 +11       SET LEXSCHG("757",0)=""

           SET LEXSCHG("757.001",0)=""

           SET LEXSCHG("757.01",0)=""

           SET LEXSCHG("757.02",0)=""

           SET LEXSCHG("757.1",0)=""

 +12       SET LEXSCHG("B","757")=""

           SET LEXSCHG("B","757.001")=""

           SET LEXSCHG("B","757.01")=""

           SET LEXSCHG("B","757.02")=""

           SET LEXSCHG("B","757.1")=""

 +13       SET LEXSCHG("C","LEX","757")=""

           SET LEXSCHG("C","LEX","757.001")=""

           SET LEXSCHG("C","LEX","757.01")=""

           SET LEXSCHG("C","LEX","757.02")=""

           SET LEXSCHG("C","LEX","757.1")=""

 +14       SET LEXSCHG("D","PRO")=""

           SET LEXSHORT=""

 +15       DO DDUZ

           DO CHGF

           DO RTN

           DO INST

           DO NOTIFY

           DO MSG2

           DO KALL^LEXXGI2

 +16       QUIT 

INST      ; Installed Patches

 +1        NEW INST,STR

           DO BL

 +2        SET INST=$$PROK("PXRMCSD",9)

           SET STR=" PXRM*2.0*9      "_$SELECT(INST>0:"Installed",1:"Not Installed")

           DO BM(STR)

           DO TL(STR)

 +3        SET INST=$$PROK("ICDUPDT",28)

           SET STR=" ICD*18.0*28     "_$SELECT(INST>0:"Installed",1:"Not Installed")

           DO M(STR)

           DO TL(STR)

 +4        SET INST=$$PROK("ICPTAU",34)

           SET STR=" ICPT*6.0*34     "_$SELECT(INST>0:"Installed",1:"Not Installed")

           DO M(STR)

           DO TL(STR)

 +5        SET INST=$$PROK("LEXXGI",49)

           SET STR=" LEX*2.0*49      "_$SELECT(INST>0:"Installed",1:"Not Installed")

           DO M(STR)

           DO TL(STR)

 +6        QUIT 

NOTIFY    ; Notify by Protocol - LEXICAL SERVICES UPDATE

 +1        NEW LEXP,X,STR

 +2        SET STR="ERROR:  Array of files not found"

           if '$DATA(LEXSCHG)

               DO BM(STR)

               DO BL

               DO TL(STR)

           if '$DATA(LEXSCHG)

               QUIT 

 +3        SET LEXP=+($ORDER(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))

 +4        SET STR="ERROR:  LEXICAL SERVICES UPDATE protocol not found"

           if $GET(LEXP)'>0

               DO BM(STR)

               DO BL

               DO TL(STR)

           if LEXP=0

               QUIT 

 +5        SET X=LEXP_";ORD(101,"

           DO EN^XQOR

 +6        SET STR="ERROR:  LEXICAL SERVICES UPDATE protocol not invoked"

           if $DATA(LEXSCHG)

               DO BM(STR)

               DO BL

               DO TL(STR)

           if $DATA(LEXSCHG)

               QUIT 

 +7        SET ^LEXM(0,"PRO")=$$NOW^XLFDT

           SET X="Protocol 'LEXICAL SERVICES UPDATE' was invoked"

 +8        if '$DATA(XPDNM)

               WRITE !!,X

           if $DATA(XPDNM)

               DO BM(X)

 +9        SET (STR,X)="Subscribing applications were notified"

           SET STR="  "_STR

           DO BL

           DO TL(STR)

 +10       if '$DATA(XPDNM)

               WRITE !,X

           if $DATA(XPDNM)

               DO M(X)

 +11       QUIT 

CHGF      ; Change File

 +1        DO M(" ")

           DO RI("Removing Change Files (757.9-757.91)","Remedy 175985")

           NEW FI,FNAME,ERR,ROK,STR

 +2        SET FI=757.91

           SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")

           IF $LENGTH(FNAME)

               Begin DoDot:1

 +3                NEW DIU,ERR

                   SET DIU="^LEXC("_FI_","

                   SET DIU(0)="D"

                   DO EN^DIU2

                   if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))

                       KILL ^LEXC(FI)

               End DoDot:1

 +4        SET FI=757.903

           SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")

           IF $LENGTH(FNAME)

               Begin DoDot:1

 +5                NEW DIU,ERR

                   SET DIU="^LEXC("_FI_","

                   SET DIU(0)="D"

                   DO EN^DIU2

                   if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))

                       KILL ^LEXC(FI)

               End DoDot:1

 +6        SET FI=757.9

           SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")

           IF $LENGTH(FNAME)

               Begin DoDot:1

 +7                NEW DIU,ERR

                   SET DIU="^LEXC("_FI_","

                   SET DIU(0)="D"

                   DO EN^DIU2

                   if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))

                       KILL ^LEXC(FI)

               End DoDot:1

 +8        SET FI=757.901

           SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")

           IF $LENGTH(FNAME)

               Begin DoDot:1

 +9                NEW DIU,ERR

                   SET DIU="^LEXC("_FI_","

                   SET DIU(0)="D"

                   DO EN^DIU2

                   if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))

                       KILL ^LEXC(FI)

               End DoDot:1

 +10       SET FI=757.902

           SET FNAME=$$GET1^DID(FI,"","","NAME","","ERR")

           IF $LENGTH(FNAME)

               Begin DoDot:1

 +11               NEW DIU,ERR

                   SET DIU="^LEXC("_FI_","

                   SET DIU(0)="D"

                   DO EN^DIU2

                   if '$LENGTH($$GET1^DID(FI,"","","NAME","","ERR"))

                       KILL ^LEXC(FI)

               End DoDot:1

 +12       IF '$DATA(^LEXC)

               SET STR="Removed Change Files (757.9-757.91) (Remedy 175985)"

               DO BL

               DO TL(STR)

               QUIT 

 +13       QUIT 

RTN       ; Routines

 +1        DO M(" ")

           DO BL

           DO DRTN

           DO MRTN

 +2        QUIT 

DRTN      ; Delete Routines

 +1        NEW EXEC,ROK,RTN,STR,X

 +2        SET X=$GET(^%ZOSF("DEL"))

           if '$LENGTH(X)

               QUIT 

           DO ^DIM

           if '$DATA(X)

               QUIT 

           if '$LENGTH(X)

               QUIT 

           SET EXEC=X

 +3        FOR RTN="LEXCHGF","LEXCHGF2","LEXNDX7","LEXXST5"

               Begin DoDot:1

 +4                SET ROK=+($$ROK(RTN))

                   IF +ROK'>0

                       SET STR="    "_RTN

                       SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_"Deleted"

                       DO M(STR)

                       DO TL(STR)

                       QUIT 

 +5                SET X=RTN

                   XECUTE EXEC

 +6                SET ROK=+($$ROK(RTN))

                   IF +ROK'>0

                       SET STR="    "_RTN

                       SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_"Deleted"

                       DO M(STR)

                       DO TL(STR)

                       QUIT 

 +7                SET STR="    "_RTN

                   DO M(STR)

                   DO TL(STR)

               End DoDot:1

 +8        QUIT 

MRTN      ; Modified Routines

 +1        NEW CNT,EXEC,FIX,I,RTN,PN,PNO,STR,TXT,TY

           SET CNT=0

           FOR I=1:1

               Begin DoDot:1

 +2                SET TXT=""

                   SET EXEC="S TXT=$T(MRN+"_I_"^LEX2049P)"

                   XECUTE EXEC

 +3                SET TXT=$PIECE(TXT,";;",2,299)

                   if TXT=""

                       QUIT 

 +4                SET RTN=$PIECE(TXT,";",1)

                   if '$LENGTH(RTN)

                       SET TXT=""

                   if '$LENGTH(TXT)

                       QUIT 

                   if +($$ROK(RTN))=0

                       QUIT 

 +5                SET PN=$PIECE(TXT,";",2)

                   SET TY=$PIECE(TXT,";",3)

                   SET FIX=$PIECE(TXT,";",4)

 +6                SET PNO=$$PROK(RTN,PN)

 +7                SET STR="    "_RTN

                   if +PNO>0

                       SET STR=STR_$JUSTIFY(" ",(17-$LENGTH(STR)))_TY

                   if +PNO>0

                       SET STR=STR_$JUSTIFY(" ",(29-$LENGTH(STR)))_FIX

 +8                DO M(STR)

                   DO TL(STR)

               End DoDot:1

               if '$LENGTH(TXT)

                   QUIT 

 +9        QUIT 

MRN       ; Modified Routine Names

 +1       ;;LEXXFI;49;Modified;Removed references to file #757.9

 +2       ;;LEXXFI7;49;Modified;Removed references to file #757.9

 +3       ;;LEXXST;49;Modified;Removed references to file #757.9

 +4       ;;LEXXGI;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol

 +5       ;;LEXXGI2;49;Modified;Fix LEXICAL SERVICES UPDATE Protocol

 +6       ;;LEXXII;49;Modified;Fix Install Message (Protocol)

 +7       ;;ICDUPDT;28;Modified;Fix ICD CODE UPDATE EVENT Protocol

 +8       ;;ICPTAU;34;Modified;Fix ICPT CODE UPDATE EVENT Protocol

 +9       ;;PXRMCSD;9;Modified;Fix ICD/CPT Reminder Dialogs Message

 +10      ;;PXRMCSTX;9;Modified;Fix ICD/CPT Reminder Taxonomies Message

 +11      ;;

DDUZ      ; Delete Exported DUZ if broken Pointer

 +1        NEW STR

           SET STR="Removing broken Pointer in file #757.2"

 +2        DO M(" ")

           DO RI(STR,"ROF LEX*2.0*46")

           SET STR=STR_" (ROF LEX*2.0*46)"

           if $LENGTH($$GET1^DIQ(200,("1118,"),.01))

               QUIT 

 +3        DO BL

           DO TL(STR)

           NEW DA,DIK,NAME,SSIEN

           SET SSIEN=0

           FOR 

               SET SSIEN=$ORDER(^LEXT(757.2,SSIEN))

               if +SSIEN'>0

                   QUIT 

               Begin DoDot:1

 +4                if '$DATA(^LEXT(757.2,SSIEN,200))

                       QUIT 

                   if $ORDER(^LEXT(757.2,SSIEN,200,0))'>0

                       QUIT 

                   if '$DATA(^LEXT(757.2,SSIEN,200,1118))

                       QUIT 

 +5                NEW DA,DIK,NAME

                   SET NAME=$PIECE($GET(^LEXT(757.2,SSIEN,0)),"^",1)

                   if $LENGTH(NAME)

                       DO CI(("  "_NAME))

 +6                SET DA(1)=SSIEN

                   SET DA=1118

                   SET DIK="^LEXT(757.2,"_SSIEN_",200,"

                   DO ^DIK

               End DoDot:1

 +7        QUIT 

ROK(X)    ; Routine OK

 +1        SET X=$GET(X)

           if '$LENGTH(X)

               QUIT 0

           if $LENGTH(X)>8

               QUIT 0

           XECUTE ^%ZOSF("TEST")

           if $TEST

               QUIT 1

           QUIT 0

PROK(X,Y) ; Routine and Patch # OK (in UCI)

 +1        NEW LEX,LEXI,LEXO

           SET X=$GET(X)

           SET Y=$GET(Y)

           if '$LENGTH(X)

               QUIT 0

           if Y'=""&(+Y=0)

               QUIT 

 +2        SET Y=+Y

           SET LEX=$$ROK(X)

           if 'LEX

               QUIT 0

           if +Y=0

               QUIT 1

           SET LEXO=0

           SET LEX=$TEXT(@("+2^"_X))

           SET LEX=$PIECE($PIECE(LEX,"**",2),"**",1)

 +3        FOR LEXI=1:1:$LENGTH(LEX,",")

               if +($PIECE(LEX,",",LEXI))=Y

                   SET LEXO=1

               if LEXO=1

                   QUIT 

 +4        SET X=LEXO

 +5        QUIT X

LL(T,X)   ; Line Label

 +1        NEW RTN,TAG,ROK,EXEC,OK

           SET TAG=$GET(T)

           SET RTN=$GET(X)

           if '$LENGTH(RTN)

               QUIT 0

           SET ROK=$$ROK(RTN)

           if +ROK'>0

               QUIT 0

           if '$LENGTH(TAG)&($LENGTH(RTN))

               SET TAG=RTN

 +2        SET OK=0

           SET EXEC="S OK=$L($T("_TAG_"^"_RTN_")) S OK=$S(OK>0:1,1:0)"

           XECUTE EXEC

           SET X=+($GET(OK))

 +3        QUIT X

MSG1      ; Send Installation Message to G.LEXICON

 +1        KILL ^TMP("LEXCS",$JOB),^TMP("LEXCNT",$JOB),^TMP("LEXI",$JOB),^TMP("LEXMSG",$JOB)

 +2        KILL ^TMP("LEXINS",$JOB),^TMP("LEXKID",$JOB)

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        NEW LEXBEG,LEXELP,LEXEND,LEXFC,LEXMOD,LEXMUL,LEXTCS,LEXTND,LEXID,ZTQUEUED

 +4        SET LEXID="LEXKID"

           SET LEXMUL=1

           SET (LEXTND,LEXTCS,LEXMOD,LEXFC,ZTQUEUED)=0

 +5        DO HDR^LEXXFI

           DO EN^LEXXII

           KILL ^LEXM(0,"PRO")

 +6        QUIT 

MSG2      ; Send Installation (part 2)

 +1        NEW LEXSHORT,ZTQUEUED,LEXBUILD

           SET ZTQUEUED=0

           SET LEXSHORT=1

           SET LEXBUILD="LEX*2.0*49"

 +2        DO MAIL^LEXXFI

           DO KILL^LEXXFI

 +3        QUIT 

ENV(X)    ; Environment check

 +1        NEW LEXNM

           DO HOME^%ZIS

           SET U="^"

           SET DT=$$DT^XLFDT

           SET LEXNM=$$GET1^DIQ(200,+($GET(DUZ)),.01)

           SET DTIME=$$DTIME^XUP(+($GET(DUZ)))

           if +($GET(DUZ))'>0!('$LENGTH(LEXNM))

               QUIT 0

 +2        QUIT 1

ED(LEX)   ; External Date MM/DD/YYYY TT:TT

 +1        NEW XPDNM

           SET LEX=$$FMTE^XLFDT($GET(LEX),"1Z")

           if LEX["@"

               SET LEX=$PIECE(LEX,"@",1)_"  "_$PIECE(LEX,"@",2,299)

 +2        QUIT LEX

RI(X,Y)   ; Reference - Indented

 +1        NEW I

           SET X=$GET(X)

           SET Y=$GET(Y)

           if '$LENGTH(X)

               QUIT 

 +2        IF $LENGTH(Y)

               SET X="    "_X

               FOR 

                   if $LENGTH(X)>54

                       QUIT 

                   SET X=X_" "

 +3        SET X=X_" "_Y

           if $EXTRACT(X,1)'=" "

               SET X="    "_X

           DO MES^XPDUTL(X)

           QUIT 

CI(X)     ; Comment Text - Indented

 +1        NEW I

           SET X=$GET(X)

           if '$LENGTH(X)

               QUIT 

           SET X="    "_X