LEX2046P.m

LEX2046P ; CIO ISL - LEX*2.0*46 Pre/Post Install           ; 01/01/2007

 ;;2.0;LEXICON UTILITY;**46**;Sep 23, 1996

 ;

 ; External References

 ;   DBIA 10086  HOME^%ZIS

 ;   DBIA  2052  $$GET1^DID

 ;   DBIA  2055  PRD^DILFD

 ;   DBIA 10014  EN^DIU2

 ;   DBIA 10141  BMES^XPDUTL

 ;   DBIA 10141  MES^XPDUTL

 ;                      

 Q

 ;                      

POST ; LEX*2.0*46 Post-Install

 N LEXEDT,LEXCHG,LEXSCHG,LEXMUMPS,LEXSHORT S LEXEDT=$G(^LEXM(0,"CREATED")),LEXSHORT=""

 S LEXCHG=0 S:$D(^LEXM(80))!($D(^LEXM(80.1)))!($D(^LEXM(81)))!($D(^LEXM(81.2)))!($D(^LEXM(81.3))) LEXCHG=1

 ;

 ;-----------------------------

 ;   Save Changes

 D SCHG

 ;

 ;-----------------------------

 ;   Load Data into Files

 D LOAD

 ;

 ;-----------------------------

 ;   Data Conversion

 D CON

 ;

 ;-----------------------------

 ;   Re-Index Files - N/A for LEX*2.0*46

 ;   Do not use for Annual/Quarterly Updates, it disrupts the Protocol

 ;   D RX

 ;

 ;-----------------------------

 ;   Fire Protocol 

 D NOTIFY^LEXXGI

 ;

 ;-----------------------------

 ;   Send a Install Message

 D MSG

 ;

 ;-----------------------------

 ;   Clean up and Quit

 D KLEXM

 Q

 ;                      

LOAD ; Load Data from ^LEXM into IC*/LEX Files

 N LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST D IMP^LEX2046

 S LEXSTR=$G(LEXPTYPE) S:$L($G(LEXFY))&($L($G(LEXQTR))) LEXSTR=LEXSTR_" for "_$G(LEXFY)_" "_$G(LEXQTR)_" Quarter"

 S U="^",LEXB=$G(^LEXM(0,"BUILD")) Q:LEXB=""  Q:LEXBUILD=""

 S LEXCD=0 S LEXCD=+($$CPD^LEX2046)

 I LEXCD,LEXB=LEXBUILD D  G LQ

 . S X="Data for patch "_LEXBUILD_" has already been installed"

 . W:'$D(XPDNM) !!,X D:$D(XPDNM) BMES^XPDUTL(X)

 . S X="" W:'$D(XPDNM) ! D:$D(XPDNM) MES^XPDUTL(X)

 D:'LEXCD&(LEXB=LEXBUILD) EN^LEXXGI

LQ ; Load Quit

 D KLEXM

 Q

 ;

MSG ; Send Installation Message to G.LEXICON

 Q:+($G(DUZ))=0!($$NOTDEF^LEX2046($G(DUZ)))

 D HOME^%ZIS N DIFROM,LEXPRO,LEXPRON,LEXLAST,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXSHORT

 S LEXSHORT="" D IMP^LEX2046,POST^LEXXFI Q

 ;

SCHG ; Save Change File Changes

 N NN,NC,ND K LEXSCHG(0) S LEXCHG=0 S NN="^LEXM",NC="^LEXM(" F  S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC)  D

 . S ND=$G(@NN) I NN["LEXM(80,"&(+($P(NN,",",2))>1)!(NN["LEXM(80.1,"&(+($P(NN,",",2))>1)) D

 . . S:ND["S ^ICD9("!(ND["K ^ICD9(") LEXSCHG(80,0)=+($G(^LEXM(80,0))),LEXSCHG("B",80)="",LEXSCHG("C","ICD",80)="",LEXSCHG("D","PRO")=""

 . . S:ND["S ^ICD0("!(ND["K ^ICD0(") LEXSCHG(80.1,0)=+($G(^LEXM(80.1,0))),LEXSCHG("B",80.1)="",LEXSCHG("C","ICD",80.1)="",LEXSCHG("D","PRO")=""

 . I NN["LEXM(81,"&(+($P(NN,",",2))>1)!(NN["LEXM(81.3,"&(+($P(NN,",",2))>1)) D

 . . S:ND["S ^ICPT("!(ND["K ^ICPT(") LEXSCHG(81,0)=+($G(^LEXM(81,0))),LEXSCHG("B",81)="",LEXSCHG("C","CPT",81)="",LEXSCHG("D","PRO")=""

 . . S:ND["S ^DIC(81.3,"!(ND["K ^DIC(81.3,") LEXSCHG(81.3,0)=+($G(^LEXM(81.3,0))),LEXSCHG("B",81.3)="",LEXSCHG("C","CPT",81.3)="",LEXSCHG("D","PRO")=""

 . I NN["LEXM(81.2," D

 . . S:ND["S ^DIC(81.2,"!(ND["K ^DIC(81.2,") LEXSCHG(81.2,0)=+($G(^LEXM(81.2,0))),LEXSCHG("B",81.2)="",LEXSCHG("C","CPT",81.2)=""

 . I NN["LEXM(757,"&(+($P(NN,",",2))>1)!(NN["LEXM(757."&(+($P(NN,",",2))>1)) D

 . . N FI S FI=+($P(NN,"(",2))

 . . S:ND["S ^LEX("!(ND["K ^LEX(") LEXSCHG(FI,0)=+($G(^LEXM(+FI,0))),LEXSCHG("B",FI)="",LEXSCHG("C","LEX",FI)="",LEXSCHG("D","PRO")=""

 . . S:ND["S ^LEXT("!(ND["K ^LEXT(") LEXSCHG(FI,0)=+($G(^LEXM(+FI,0))),LEXSCHG("B",FI)="",LEXSCHG("C","LEX",FI)="",LEXSCHG("D","PRO")=""

 S:$D(^LEXM(80))!($D(^LEXM(80.1)))!($D(^LEXM(81)))!($D(^LEXM(81.2)))!($D(^LEXM(81.3)))!($D(LEXSCHG("D","PRO"))) LEXCHG=1,LEXSCHG(0)=1

 Q

 ;

KLEXM ; Subscripted Kill of ^LEXM

 N DA S DA=0 F  S DA=$O(^LEXM(DA)) Q:+DA=0  K ^LEXM(DA)

 N LEX S LEX=$G(^LEXM(0,"PRO")) K ^LEXM(0) S:$L(LEX) ^LEXM(0,"PRO")=LEX

 Q

 ;

PRE ; LEX*2.0*46 Pre-Install   (N/A for patch 46)

 Q

 ;

RX ; Reindex files            (N/A for patch 46)

 Q

 N LEX,DA,DIK,TH,TM,TD

 D BMES^XPDUTL(" Re-indexing NEW Versioned Text Cross-References")

 ;

 D BMES^XPDUTL("   ICD-9 Diagnosis file                 #80") W !,"   "

 S (LEX,DA)=0 F  S DA=$O(^ICD9(DA)) Q:+DA=0  K ^ICD9(DA,66,"B"),^ICD9(DA,67,"B"),^ICD9(DA,68,"B") S LEX=+($G(LEX))+1 W:LEX#120=0 "."

 K ^ICD9("AB"),^ICD9("ACC"),^ICD9("ACT"),^ICD9("BA"),^ICD9("D"),^ICD9("AST"),^ICD9("ADS") S DIK="^ICD9(" D IXALL^DIK

 ;

 D MES^XPDUTL("   ICD-9 Operations/Procedure file      #80.1") W !,"   "

 S (LEX,DA)=0 F  S DA=$O(^ICD0(DA)) Q:+DA=0  K ^ICD0(DA,66,"B"),^ICD0(DA,67,"B"),^ICD0(DA,68,"B") S LEX=+($G(LEX))+1 W:LEX#120=0 "."

 K ^ICD0("AB"),^ICD0("ACT"),^ICD0("ADS"),^ICD0("AST"),^ICD0("BA"),^ICD0("D"),^ICD0("E") S DIK="^ICD0(" D IXALL^DIK

 ;

 D MES^XPDUTL("   DRG file                             #80.2") W !,"   "

 S (LEX,DA)=0 F  S DA=$O(^ICD(DA)) Q:+DA=0  K ^ICD(DA,1,"B"),^ICD(DA,66,"B"),^ICD(DA,68,"B") S LEX=+($G(LEX))+1 W:LEX#120=0 "."

 K ^ICD("ADS"),^ICD("B") S DIK="^ICD(" D IXALL^DIK

 ;

 D MES^XPDUTL("   CPT/HCPCS Procedure/Services file    #81") W !,"   "

 S (LEX,DA)=0 F  S DA=$O(^ICPT(DA)) Q:+DA=0  D

 . K ^ICPT(DA,60,"B"),^ICPT(DA,61,"B"),^ICPT(DA,62,"B"),^ICPT(DA,"D","B") S LEX=+($G(LEX))+1 W:LEX#120=0 "."

 K ^ICPT("ACT"),^ICPT("ADS"),^ICPT("AST"),^ICPT("B"),^ICPT("BA"),^ICPT("C"),^ICPT("D"),^ICPT("E"),^ICPT("F") S DIK="^ICPT(" D IXALL^DIK

 ;

 D MES^XPDUTL("   CPT Modifier file                    #81.3") W !,"   "

 S (LEX,DA)=0 F  S DA=$O(^DIC(81.3,DA)) Q:+DA=0  D

 . K ^DIC(81.3,DA,60,"B"),^DIC(81.3,DA,61,"B"),^DIC(81.3,DA,62,"B") S LEX=+($G(LEX))+1 W:LEX#120=0 "."

 K ^DIC(81.3,"ACT"),^DIC(81.3,"ADS"),^DIC(81.3,"AST"),^DIC(81.3,"B"),^DIC(81.3,"BA"),^DIC(81.3,"C"),^DIC(81.3,"D"),^DIC(81.3,"M") S DIK="^DIC(81.3," D IXALL^DIK

 Q

 ;

CON ; Conversion of data       (N/A for patch 46)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEX2046P   5781     printed  Feb 18, 2025@23:30:16                                                                                                                                                                                                    Page 2

LEX2046P  ; CIO ISL - LEX*2.0*46 Pre/Post Install           ; 01/01/2007

 +1       ;;2.0;LEXICON UTILITY;**46**;Sep 23, 1996

 +2       ;

 +3       ; External References

 +4       ;   DBIA 10086  HOME^%ZIS

 +5       ;   DBIA  2052  $$GET1^DID

 +6       ;   DBIA  2055  PRD^DILFD

 +7       ;   DBIA 10014  EN^DIU2

 +8       ;   DBIA 10141  BMES^XPDUTL

 +9       ;   DBIA 10141  MES^XPDUTL

 +10      ;                      

 +11       QUIT 

 +12      ;                      

POST      ; LEX*2.0*46 Post-Install

 +1        NEW LEXEDT,LEXCHG,LEXSCHG,LEXMUMPS,LEXSHORT

           SET LEXEDT=$GET(^LEXM(0,"CREATED"))

           SET LEXSHORT=""

 +2        SET LEXCHG=0

           if $DATA(^LEXM(80))!($DATA(^LEXM(80.1)))!($DATA(^LEXM(81)))!($DATA(^LEXM(81.2)))!($DATA(^LEXM(81.3)))

               SET LEXCHG=1

 +3       ;

 +4       ;-----------------------------

 +5       ;   Save Changes

 +6        DO SCHG

 +7       ;

 +8       ;-----------------------------

 +9       ;   Load Data into Files

 +10       DO LOAD

 +11      ;

 +12      ;-----------------------------

 +13      ;   Data Conversion

 +14       DO CON

 +15      ;

 +16      ;-----------------------------

 +17      ;   Re-Index Files - N/A for LEX*2.0*46

 +18      ;   Do not use for Annual/Quarterly Updates, it disrupts the Protocol

 +19      ;   D RX

 +20      ;

 +21      ;-----------------------------

 +22      ;   Fire Protocol 

 +23       DO NOTIFY^LEXXGI

 +24      ;

 +25      ;-----------------------------

 +26      ;   Send a Install Message

 +27       DO MSG

 +28      ;

 +29      ;-----------------------------

 +30      ;   Clean up and Quit

 +31       DO KLEXM

 +32       QUIT 

 +33      ;                      

LOAD      ; Load Data from ^LEXM into IC*/LEX Files

 +1        NEW LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST

           DO IMP^LEX2046

 +2        SET LEXSTR=$GET(LEXPTYPE)

           if $LENGTH($GET(LEXFY))&($LENGTH($GET(LEXQTR)))

               SET LEXSTR=LEXSTR_" for "_$GET(LEXFY)_" "_$GET(LEXQTR)_" Quarter"

 +3        SET U="^"

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

           if LEXB=""

               QUIT 

           if LEXBUILD=""

               QUIT 

 +4        SET LEXCD=0

           SET LEXCD=+($$CPD^LEX2046)

 +5        IF LEXCD

               IF LEXB=LEXBUILD

                   Begin DoDot:1

 +6                    SET X="Data for patch "_LEXBUILD_" has already been installed"

 +7                    if '$DATA(XPDNM)

                           WRITE !!,X

                       if $DATA(XPDNM)

                           DO BMES^XPDUTL(X)

 +8                    SET X=""

                       if '$DATA(XPDNM)

                           WRITE !

                       if $DATA(XPDNM)

                           DO MES^XPDUTL(X)

                   End DoDot:1

                   GOTO LQ

 +9        if 'LEXCD&(LEXB=LEXBUILD)

               DO EN^LEXXGI

LQ        ; Load Quit

 +1        DO KLEXM

 +2        QUIT 

 +3       ;

MSG       ; Send Installation Message to G.LEXICON

 +1        if +($GET(DUZ))=0!($$NOTDEF^LEX2046($GET(DUZ)))

               QUIT 

 +2        DO HOME^%ZIS

           NEW DIFROM,LEXPRO,LEXPRON,LEXLAST,LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXSHORT

 +3        SET LEXSHORT=""

           DO IMP^LEX2046

           DO POST^LEXXFI

           QUIT 

 +4       ;

SCHG      ; Save Change File Changes

 +1        NEW NN,NC,ND

           KILL LEXSCHG(0)

           SET LEXCHG=0

           SET NN="^LEXM"

           SET NC="^LEXM("

           FOR 

               SET NN=$QUERY(@NN)

               if '$LENGTH(NN)!(NN'[NC)

                   QUIT 

               Begin DoDot:1

 +2                SET ND=$GET(@NN)

                   IF NN["LEXM(80,"&(+($PIECE(NN,",",2))>1)!(NN["LEXM(80.1,"&(+($PIECE(NN,",",2))>1))

                       Begin DoDot:2

 +3                        if ND["S ^ICD9("!(ND["K ^ICD9(")

                               SET LEXSCHG(80,0)=+($GET(^LEXM(80,0)))

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

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

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

 +4                        if ND["S ^ICD0("!(ND["K ^ICD0(")

                               SET LEXSCHG(80.1,0)=+($GET(^LEXM(80.1,0)))

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

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

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

                       End DoDot:2

 +5                IF NN["LEXM(81,"&(+($PIECE(NN,",",2))>1)!(NN["LEXM(81.3,"&(+($PIECE(NN,",",2))>1))

                       Begin DoDot:2

 +6                        if ND["S ^ICPT("!(ND["K ^ICPT(")

                               SET LEXSCHG(81,0)=+($GET(^LEXM(81,0)))

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

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

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

 +7                        if ND["S ^DIC(81.3,"!(ND["K ^DIC(81.3,")

                               SET LEXSCHG(81.3,0)=+($GET(^LEXM(81.3,0)))

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

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

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

                       End DoDot:2

 +8                IF NN["LEXM(81.2,"

                       Begin DoDot:2

 +9                        if ND["S ^DIC(81.2,"!(ND["K ^DIC(81.2,")

                               SET LEXSCHG(81.2,0)=+($GET(^LEXM(81.2,0)))

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

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

                       End DoDot:2

 +10               IF NN["LEXM(757,"&(+($PIECE(NN,",",2))>1)!(NN["LEXM(757."&(+($PIECE(NN,",",2))>1))

                       Begin DoDot:2

 +11                       NEW FI

                           SET FI=+($PIECE(NN,"(",2))

 +12                       if ND["S ^LEX("!(ND["K ^LEX(")

                               SET LEXSCHG(FI,0)=+($GET(^LEXM(+FI,0)))

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

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

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

 +13                       if ND["S ^LEXT("!(ND["K ^LEXT(")

                               SET LEXSCHG(FI,0)=+($GET(^LEXM(+FI,0)))

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

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

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

                       End DoDot:2

               End DoDot:1

 +14       if $DATA(^LEXM(80))!($DATA(^LEXM(80.1)))!($DATA(^LEXM(81)))!($DATA(^LEXM(81.2)))!($DATA(^LEXM(81.3)))!($DATA(LEXSCHG("D","PRO")))

               SET LEXCHG=1

               SET LEXSCHG(0)=1

 +15       QUIT 

 +16      ;

KLEXM     ; Subscripted Kill of ^LEXM

 +1        NEW DA

           SET DA=0

           FOR 

               SET DA=$ORDER(^LEXM(DA))

               if +DA=0

                   QUIT 

               KILL ^LEXM(DA)

 +2        NEW LEX

           SET LEX=$GET(^LEXM(0,"PRO"))

           KILL ^LEXM(0)

           if $LENGTH(LEX)

               SET ^LEXM(0,"PRO")=LEX

 +3        QUIT 

 +4       ;

PRE       ; LEX*2.0*46 Pre-Install   (N/A for patch 46)

 +1        QUIT 

 +2       ;

RX        ; Reindex files            (N/A for patch 46)

 +1        QUIT 

 +2        NEW LEX,DA,DIK,TH,TM,TD

 +3        DO BMES^XPDUTL(" Re-indexing NEW Versioned Text Cross-References")

 +4       ;

 +5        DO BMES^XPDUTL("   ICD-9 Diagnosis file                 #80")

           WRITE !,"   "

 +6        SET (LEX,DA)=0

           FOR 

               SET DA=$ORDER(^ICD9(DA))

               if +DA=0

                   QUIT 

               KILL ^ICD9(DA,66,"B"),^ICD9(DA,67,"B"),^ICD9(DA,68,"B")

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

               if LEX#120=0

                   WRITE "."

 +7        KILL ^ICD9("AB"),^ICD9("ACC"),^ICD9("ACT"),^ICD9("BA"),^ICD9("D"),^ICD9("AST"),^ICD9("ADS")

           SET DIK="^ICD9("

           DO IXALL^DIK

 +8       ;

 +9        DO MES^XPDUTL("   ICD-9 Operations/Procedure file      #80.1")

           WRITE !,"   "

 +10       SET (LEX,DA)=0

           FOR 

               SET DA=$ORDER(^ICD0(DA))

               if +DA=0

                   QUIT 

               KILL ^ICD0(DA,66,"B"),^ICD0(DA,67,"B"),^ICD0(DA,68,"B")

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

               if LEX#120=0

                   WRITE "."

 +11       KILL ^ICD0("AB"),^ICD0("ACT"),^ICD0("ADS"),^ICD0("AST"),^ICD0("BA"),^ICD0("D"),^ICD0("E")

           SET DIK="^ICD0("

           DO IXALL^DIK

 +12      ;

 +13       DO MES^XPDUTL("   DRG file                             #80.2")

           WRITE !,"   "

 +14       SET (LEX,DA)=0

           FOR 

               SET DA=$ORDER(^ICD(DA))

               if +DA=0

                   QUIT 

               KILL ^ICD(DA,1,"B"),^ICD(DA,66,"B"),^ICD(DA,68,"B")

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

               if LEX#120=0

                   WRITE "."

 +15       KILL ^ICD("ADS"),^ICD("B")

           SET DIK="^ICD("

           DO IXALL^DIK

 +16      ;

 +17       DO MES^XPDUTL("   CPT/HCPCS Procedure/Services file    #81")

           WRITE !,"   "

 +18       SET (LEX,DA)=0

           FOR 

               SET DA=$ORDER(^ICPT(DA))

               if +DA=0

                   QUIT 

               Begin DoDot:1

 +19               KILL ^ICPT(DA,60,"B"),^ICPT(DA,61,"B"),^ICPT(DA,62,"B"),^ICPT(DA,"D","B")

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

                   if LEX#120=0

                       WRITE "."

               End DoDot:1

 +20       KILL ^ICPT("ACT"),^ICPT("ADS"),^ICPT("AST"),^ICPT("B"),^ICPT("BA"),^ICPT("C"),^ICPT("D"),^ICPT("E"),^ICPT("F")

           SET DIK="^ICPT("

           DO IXALL^DIK

 +21      ;

 +22       DO MES^XPDUTL("   CPT Modifier file                    #81.3")

           WRITE !,"   "

 +23       SET (LEX,DA)=0

           FOR 

               SET DA=$ORDER(^DIC(81.3,DA))

               if +DA=0

                   QUIT 

               Begin DoDot:1

 +24               KILL ^DIC(81.3,DA,60,"B"),^DIC(81.3,DA,61,"B"),^DIC(81.3,DA,62,"B")

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

                   if LEX#120=0

                       WRITE "."

               End DoDot:1

 +25       KILL ^DIC(81.3,"ACT"),^DIC(81.3,"ADS"),^DIC(81.3,"AST"),^DIC(81.3,"B"),^DIC(81.3,"BA"),^DIC(81.3,"C"),^DIC(81.3,"D"),^DIC(81.3,"M")

           SET DIK="^DIC(81.3,"

           DO IXALL^DIK

 +26       QUIT 

 +27      ;

CON       ; Conversion of data       (N/A for patch 46)

 +1        QUIT