LEX2103P ;ISL/KER - LEX*2.0*103 Pre/Post Install ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.3) SACC 1.3
;
; External References
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
; DESC^%ZTLOAD ICR 10063
; STAT^%ZTLOAD ICR 10063
; ENALL^DIK ICR 10013
; IX1^DIK ICR 10013
; ^DIK ICR 10013
; EN^DIU2 ICR 10014
; MES^XPDUTL ICR 10141
;
Q
PRE ; Pre-Install
N DIU
S DIU="^LEX(757.01,",DIU(0)="" D EN^DIU2
S DIU="^LEX(757.02,",DIU(0)="" D EN^DIU2
S DIU="^LEX(757.33,",DIU(0)="" D EN^DIU2
Q
POST ; Post-Install
D CON,REPAIR,MSG
Q
CON ; Data Conversions/Edits
D SUB,FIL,RIX,REM
Q
SUB ; ICD-10-CM Preferred Terms Subset
N DA,DIK S DA=50,DIK="^LEXT(757.2," I $D(^LEXT(757.2,DA)) D ^DIK
S ^LEXT(757.2,50,0)="ICD-10-CM Preferred Terms"
S ^LEXT(757.2,50,1)="^LEX(757.01,"
S ^LEXT(757.2,50,2)="XTLK^LEXHLP"
S ^LEXT(757.2,50,3)="XTLK^LEXPRNT"
S ^LEXT(757.2,50,4)="10D"
S ^LEXT(757.2,50,5)="XDX^WRD^0^757.01^^0^1"
S ^LEXT(757.2,50,6)="I $L($$PRF^LEXU(+Y,+($G(LEXVDT)),30))"
S ^LEXT(757.2,50,7)="10D"
S ^LEXT(757.2,50,100,0)="^^5^5^3160425^"
S ^LEXT(757.2,50,100,1,0)="This subset is artificially created through the use of a filter"
S ^LEXT(757.2,50,100,2,0)="which will filters out all entries not linked to an active ICD-10"
S ^LEXT(757.2,50,100,3,0)="diagnostic code and not flagged as the preferred term for the"
S ^LEXT(757.2,50,100,4,0)="ICD-10 diagnostic code. Synonyms, Lexical Variants and Orphans"
S ^LEXT(757.2,50,100,5,0)="will not be returned."
S DA=50,DIK="^LEXT(757.2," D IX1^DIK
Q
FIL ; ICD-10-CM Preferred Terms Filter
S DA=16,DIK="^LEX(757.3," I $D(^LEXT(757.3,DA)) D ^DIK
S ^LEX(757.3,16,0)="ICD-10-CM Preferred Terms^A"
S ^LEX(757.3,16,1)="I $L($$PRF^LEXU(+Y,+($G(LEXVDT)),30))"
S ^LEX(757.3,16,2,0)="^757.305^4^4^3160425^^"
S ^LEX(757.3,16,2,1,0)="This screen filters out all entries not linked"
S ^LEX(757.3,16,2,2,0)="to an active ICD-10 diagnostic code and not"
S ^LEX(757.3,16,2,3,0)="flagged as the preferred term for the ICD-10"
S ^LEX(757.3,16,2,4,0)="diagnostic code."
S ^LEX(757.3,16,3,0)="^757.36^3^3"
S ^LEX(757.3,16,3,1,0)="ICD"
S ^LEX(757.3,16,3,2,0)="10D"
S ^LEX(757.3,16,3,3,0)="WRD"
S DA=16,DIK="^LEX(757.3," D IX1^DIK
Q
;
REM ; Remove Fields in files 757.01 and 757.02
N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
S ZTRTN="REMT^LEX2103P" S ZTDESC="Remove unused fields from EXPRESSIONS file #757.01"
S ZTIO="",ZTDTH=$H,ZTPRI=1 D ^%ZTLOAD D HOME^%ZIS
Q
REMT ; Remove Fields in files 757.01 and 757.02 - Tasked
;
; EXPRESSION file 757.01 - Approved Mon 10/24/2016 11:11 AM
; Remove Data if it exist
N DA,DIK S DA=0 F S DA=$O(^LEX(757.01,DA)) Q:+DA'>0 D
. N ND1,CTL S (CTL,ND1)=$G(^LEX(757.01,DA,1))
. ; 5 2;1 DISTINGUISHING TEXT
. K ^LEX(757.01,DA,2)
. ; 10 1;6 MODIFIER FLAG
. S $P(ND1,"^",6)=""
. ; 11 1;7 MODIFIER TYPE
. S $P(ND1,"^",7)=""
. ; 12 1;8 DESCENDANT FLAG
. S $P(ND1,"^",8)=""
. ; 13 1;9 PARENT
. S $P(ND1,"^",9)=""
. ; 14 1;10 ORDER
. S $P(ND1,"^",10)=""
. S ND1=$$TM(ND1,"^") S:ND1'=CTL ^LEX(757.01,DA,1)=ND1
; Remove field if it exist
S DIK="^DD(757.01,",DA=5,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
S DIK="^DD(757.01,",DA=10,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
S DIK="^DD(757.01,",DA=11,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
S DIK="^DD(757.01,",DA=12,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
S DIK="^DD(757.01,",DA=13,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
S DIK="^DD(757.01,",DA=14,DA(1)=757.01 D:$D(@(DIK_DA_",0)")) ^DIK
;
; CODES file 757.02 - Pending
; Remove Data if it exist
N DA,DIK S DA=0 F S DA=$O(^LEX(757.02,DA)) Q:+DA'>0 D
. N ND0,CTL S (CTL,ND0)=$G(^LEX(757.02,DA,0))
. ; 5 0;6 DEACTIVATION FLAG
. S $P(ND0,"^",6)=""
. S ND0=$$TM(ND0,"^") S:ND0'=CTL ^LEX(757.02,DA,0)=ND0
K ^LEX(757.02,"ACODE"),^LEX(757.02,"ADC"),^LEX(757.02,"ADCODE")
; Remove field if it exist
S DIK="^DD(757.02,",DA=5,DA(1)=757.02 D:$D(@(DIK_DA_",0)")) ^DIK
Q
;
MSG ; Install Message
N LEXBUILD,LEXFILES,LEXEFFDT
S LEXBUILD="LEX*2.0*103"
S LEXFILES="757.01^757.02^757.07^757.071^757.2^757.3^757.33"
S LEXEFFDT="3170101"
D MSG^LEXXGI(LEXBUILD,LEXFILES,LEXEFFDT)
Q
;
REPAIR ; Repair Special Lookup Indexes - task
N Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,LEXTN,LEXT,LEXMAIL
S LEXMAIL="",ZTRTN="ALL^LEXXGP1",(LEXTN,ZTDESC)="LEX*2.0*103 post install repair",ZTSAVE("LEXMAIL")=""
I $D(LEXHOME) S LEXHOME=1,ZTSAVE("LEXHOME")=""
S ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS I +($G(ZTSK))>0 D
. N LEXT S LEXT=" "_$G(LEXTN)_" tasked (#"_+($G(ZTSK))_")"
. D MES^XPDUTL(LEXT)
K X,Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,LEXTN,LEXT,LEXMAIL,LEXHOME
Q
RIX ; Repair non-Special Lookup Indexes
N ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE D RAH,RB,ADT
Q
RAH ; Repair "AH" Index
N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
S ZTRTN="RAH^LEXRXC" S ZTDESC="Set AH index in EXPRESSIONS file #757.01"
S ZTIO="",ZTDTH=$H,ZTPRI=1 D ^%ZTLOAD D HOME^%ZIS
Q
RB ; Repair "B" Index
N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
S ZTRTN="RB^LEXRXC" S ZTDESC="Set B index in EXPRESSIONS file #757.01"
S ZTIO="",ZTDTH=$H,ZTPRI=1 D ^%ZTLOAD D HOME^%ZIS
Q
ADT ; Repair "ADTERM" Index
N ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
S ZTRTN="RADTERM^LEXRXC" S ZTDESC="Set ADTERM index in EXPRESSIONS file #757.01"
S ZTIO="",ZTDTH=$H,ZTPRI=1 D ^%ZTLOAD D HOME^%ZIS
Q
RUN(X) ; Task running
N LEXD,LEXLIST,ZTSK,LEXOK S LEXD="LEX*2.0*103 post install repair"
D DESC^%ZTLOAD(LEXD,"LEXLIST")
S LEXOK="0^LEX*2.0*103 post install repair task is not running"
S ZTSK=" " F S ZTSK=$O(LEXLIST(ZTSK),-1) Q:+ZTSK'>0 D
. D STAT^%ZTLOAD I +($G(ZTSK(0)))'>0 K LEXLIST(ZTSK) Q
. I "^1^2^"'[("^"_+($G(ZTSK(1)))_"^") K LEXLIST(ZTSK) Q
. Q:+LEXOK>0 S:+($G(ZTSK(1)))=1 LEXOK="1^"_LEXD_" - task pending (task #"_+($G(ZTSK))_")^"_+($G(ZTSK))
. S:+($G(ZTSK(1)))=2 LEXOK="1^"_LEXD_" - task running (task #"_+($G(ZTSK))_")^"_+($G(ZTSK))
S X=LEXOK
Q X
;
; Miscellaneous
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[HLEX2103P 6692 printed Sep 23, 2025@19:41:08 Page 2
LEX2103P ;ISL/KER - LEX*2.0*103 Pre/Post Install ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.3) SACC 1.3
+5 ;
+6 ; External References
+7 ; HOME^%ZIS ICR 10086
+8 ; ^%ZTLOAD ICR 10063
+9 ; DESC^%ZTLOAD ICR 10063
+10 ; STAT^%ZTLOAD ICR 10063
+11 ; ENALL^DIK ICR 10013
+12 ; IX1^DIK ICR 10013
+13 ; ^DIK ICR 10013
+14 ; EN^DIU2 ICR 10014
+15 ; MES^XPDUTL ICR 10141
+16 ;
+17 QUIT
PRE ; Pre-Install
+1 NEW DIU
+2 SET DIU="^LEX(757.01,"
SET DIU(0)=""
DO EN^DIU2
+3 SET DIU="^LEX(757.02,"
SET DIU(0)=""
DO EN^DIU2
+4 SET DIU="^LEX(757.33,"
SET DIU(0)=""
DO EN^DIU2
+5 QUIT
POST ; Post-Install
+1 DO CON
DO REPAIR
DO MSG
+2 QUIT
CON ; Data Conversions/Edits
+1 DO SUB
DO FIL
DO RIX
DO REM
+2 QUIT
SUB ; ICD-10-CM Preferred Terms Subset
+1 NEW DA,DIK
SET DA=50
SET DIK="^LEXT(757.2,"
IF $DATA(^LEXT(757.2,DA))
DO ^DIK
+2 SET ^LEXT(757.2,50,0)="ICD-10-CM Preferred Terms"
+3 SET ^LEXT(757.2,50,1)="^LEX(757.01,"
+4 SET ^LEXT(757.2,50,2)="XTLK^LEXHLP"
+5 SET ^LEXT(757.2,50,3)="XTLK^LEXPRNT"
+6 SET ^LEXT(757.2,50,4)="10D"
+7 SET ^LEXT(757.2,50,5)="XDX^WRD^0^757.01^^0^1"
+8 SET ^LEXT(757.2,50,6)="I $L($$PRF^LEXU(+Y,+($G(LEXVDT)),30))"
+9 SET ^LEXT(757.2,50,7)="10D"
+10 SET ^LEXT(757.2,50,100,0)="^^5^5^3160425^"
+11 SET ^LEXT(757.2,50,100,1,0)="This subset is artificially created through the use of a filter"
+12 SET ^LEXT(757.2,50,100,2,0)="which will filters out all entries not linked to an active ICD-10"
+13 SET ^LEXT(757.2,50,100,3,0)="diagnostic code and not flagged as the preferred term for the"
+14 SET ^LEXT(757.2,50,100,4,0)="ICD-10 diagnostic code. Synonyms, Lexical Variants and Orphans"
+15 SET ^LEXT(757.2,50,100,5,0)="will not be returned."
+16 SET DA=50
SET DIK="^LEXT(757.2,"
DO IX1^DIK
+17 QUIT
FIL ; ICD-10-CM Preferred Terms Filter
+1 SET DA=16
SET DIK="^LEX(757.3,"
IF $DATA(^LEXT(757.3,DA))
DO ^DIK
+2 SET ^LEX(757.3,16,0)="ICD-10-CM Preferred Terms^A"
+3 SET ^LEX(757.3,16,1)="I $L($$PRF^LEXU(+Y,+($G(LEXVDT)),30))"
+4 SET ^LEX(757.3,16,2,0)="^757.305^4^4^3160425^^"
+5 SET ^LEX(757.3,16,2,1,0)="This screen filters out all entries not linked"
+6 SET ^LEX(757.3,16,2,2,0)="to an active ICD-10 diagnostic code and not"
+7 SET ^LEX(757.3,16,2,3,0)="flagged as the preferred term for the ICD-10"
+8 SET ^LEX(757.3,16,2,4,0)="diagnostic code."
+9 SET ^LEX(757.3,16,3,0)="^757.36^3^3"
+10 SET ^LEX(757.3,16,3,1,0)="ICD"
+11 SET ^LEX(757.3,16,3,2,0)="10D"
+12 SET ^LEX(757.3,16,3,3,0)="WRD"
+13 SET DA=16
SET DIK="^LEX(757.3,"
DO IX1^DIK
+14 QUIT
+15 ;
REM ; Remove Fields in files 757.01 and 757.02
+1 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
+2 SET ZTRTN="REMT^LEX2103P"
SET ZTDESC="Remove unused fields from EXPRESSIONS file #757.01"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTPRI=1
DO ^%ZTLOAD
DO HOME^%ZIS
+4 QUIT
REMT ; Remove Fields in files 757.01 and 757.02 - Tasked
+1 ;
+2 ; EXPRESSION file 757.01 - Approved Mon 10/24/2016 11:11 AM
+3 ; Remove Data if it exist
+4 NEW DA,DIK
SET DA=0
FOR
SET DA=$ORDER(^LEX(757.01,DA))
if +DA'>0
QUIT
Begin DoDot:1
+5 NEW ND1,CTL
SET (CTL,ND1)=$GET(^LEX(757.01,DA,1))
+6 ; 5 2;1 DISTINGUISHING TEXT
+7 KILL ^LEX(757.01,DA,2)
+8 ; 10 1;6 MODIFIER FLAG
+9 SET $PIECE(ND1,"^",6)=""
+10 ; 11 1;7 MODIFIER TYPE
+11 SET $PIECE(ND1,"^",7)=""
+12 ; 12 1;8 DESCENDANT FLAG
+13 SET $PIECE(ND1,"^",8)=""
+14 ; 13 1;9 PARENT
+15 SET $PIECE(ND1,"^",9)=""
+16 ; 14 1;10 ORDER
+17 SET $PIECE(ND1,"^",10)=""
+18 SET ND1=$$TM(ND1,"^")
if ND1'=CTL
SET ^LEX(757.01,DA,1)=ND1
End DoDot:1
+19 ; Remove field if it exist
+20 SET DIK="^DD(757.01,"
SET DA=5
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+21 SET DIK="^DD(757.01,"
SET DA=10
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+22 SET DIK="^DD(757.01,"
SET DA=11
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+23 SET DIK="^DD(757.01,"
SET DA=12
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+24 SET DIK="^DD(757.01,"
SET DA=13
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+25 SET DIK="^DD(757.01,"
SET DA=14
SET DA(1)=757.01
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+26 ;
+27 ; CODES file 757.02 - Pending
+28 ; Remove Data if it exist
+29 NEW DA,DIK
SET DA=0
FOR
SET DA=$ORDER(^LEX(757.02,DA))
if +DA'>0
QUIT
Begin DoDot:1
+30 NEW ND0,CTL
SET (CTL,ND0)=$GET(^LEX(757.02,DA,0))
+31 ; 5 0;6 DEACTIVATION FLAG
+32 SET $PIECE(ND0,"^",6)=""
+33 SET ND0=$$TM(ND0,"^")
if ND0'=CTL
SET ^LEX(757.02,DA,0)=ND0
End DoDot:1
+34 KILL ^LEX(757.02,"ACODE"),^LEX(757.02,"ADC"),^LEX(757.02,"ADCODE")
+35 ; Remove field if it exist
+36 SET DIK="^DD(757.02,"
SET DA=5
SET DA(1)=757.02
if $DATA(@(DIK_DA_",0)"))
DO ^DIK
+37 QUIT
+38 ;
MSG ; Install Message
+1 NEW LEXBUILD,LEXFILES,LEXEFFDT
+2 SET LEXBUILD="LEX*2.0*103"
+3 SET LEXFILES="757.01^757.02^757.07^757.071^757.2^757.3^757.33"
+4 SET LEXEFFDT="3170101"
+5 DO MSG^LEXXGI(LEXBUILD,LEXFILES,LEXEFFDT)
+6 QUIT
+7 ;
REPAIR ; Repair Special Lookup Indexes - task
+1 NEW Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,LEXTN,LEXT,LEXMAIL
+2 SET LEXMAIL=""
SET ZTRTN="ALL^LEXXGP1"
SET (LEXTN,ZTDESC)="LEX*2.0*103 post install repair"
SET ZTSAVE("LEXMAIL")=""
+3 IF $DATA(LEXHOME)
SET LEXHOME=1
SET ZTSAVE("LEXHOME")=""
+4 SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
IF +($GET(ZTSK))>0
Begin DoDot:1
+5 NEW LEXT
SET LEXT=" "_$GET(LEXTN)_" tasked (#"_+($GET(ZTSK))_")"
+6 DO MES^XPDUTL(LEXT)
End DoDot:1
+7 KILL X,Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ,LEXTN,LEXT,LEXMAIL,LEXHOME
+8 QUIT
RIX ; Repair non-Special Lookup Indexes
+1 NEW ZTREQ,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
DO RAH
DO RB
DO ADT
+2 QUIT
RAH ; Repair "AH" Index
+1 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
+2 SET ZTRTN="RAH^LEXRXC"
SET ZTDESC="Set AH index in EXPRESSIONS file #757.01"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTPRI=1
DO ^%ZTLOAD
DO HOME^%ZIS
+4 QUIT
RB ; Repair "B" Index
+1 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
+2 SET ZTRTN="RB^LEXRXC"
SET ZTDESC="Set B index in EXPRESSIONS file #757.01"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTPRI=1
DO ^%ZTLOAD
DO HOME^%ZIS
+4 QUIT
ADT ; Repair "ADTERM" Index
+1 NEW ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,ZTPRI
+2 SET ZTRTN="RADTERM^LEXRXC"
SET ZTDESC="Set ADTERM index in EXPRESSIONS file #757.01"
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTPRI=1
DO ^%ZTLOAD
DO HOME^%ZIS
+4 QUIT
RUN(X) ; Task running
+1 NEW LEXD,LEXLIST,ZTSK,LEXOK
SET LEXD="LEX*2.0*103 post install repair"
+2 DO DESC^%ZTLOAD(LEXD,"LEXLIST")
+3 SET LEXOK="0^LEX*2.0*103 post install repair task is not running"
+4 SET ZTSK=" "
FOR
SET ZTSK=$ORDER(LEXLIST(ZTSK),-1)
if +ZTSK'>0
QUIT
Begin DoDot:1
+5 DO STAT^%ZTLOAD
IF +($GET(ZTSK(0)))'>0
KILL LEXLIST(ZTSK)
QUIT
+6 IF "^1^2^"'[("^"_+($GET(ZTSK(1)))_"^")
KILL LEXLIST(ZTSK)
QUIT
+7 if +LEXOK>0
QUIT
if +($GET(ZTSK(1)))=1
SET LEXOK="1^"_LEXD_" - task pending (task #"_+($GET(ZTSK))_")^"_+($GET(ZTSK))
+8 if +($GET(ZTSK(1)))=2
SET LEXOK="1^"_LEXD_" - task running (task #"_+($GET(ZTSK))_")^"_+($GET(ZTSK))
End DoDot:1
+9 SET X=LEXOK
+10 QUIT X
+11 ;
+12 ; Miscellaneous
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
