LEX2073B ;ISL/KER - LEX*2.0*73 Post-Install - Data ;01/03/2011
;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
;
; External Global Variables
; None
;
; External References
; FILE^DIE ICR 2053
; ^DIK ICR 10013
; IX1^DIK ICR 10013
; BMES^XPDUTL ICR 10141
; MES^XPDUTL ICR 10141
;
Q
EN ;
N DA,DIK,LEX,LEXCA,LEXCAE,LEXCC,LEXCT,LEXEX,LEXFD,LEXFM,LEXFOR,LEXID,LEXIEN,LEXIN,LEXIS,LEXLIM,LEXMA,LEXN0,LEXND,LEXOR,LEXSI,LEXSR,LEXSRC,LEXSRE,LEXSRN,LEXTGT,LEXTO
D BMES^XPDUTL(" Updating Title 38 Terminology"),BEG
D MES^XPDUTL(" Adding Mixed Case Title 38 Expressions")
D EN^LEX2073C,EN^LEX2073D,EN^LEX2073E,EN^LEX2073F,EN^LEX2073G
D MES^XPDUTL(" Adding Inactive Title 38 Codes (historical)")
D EN^LEX2073H,EN^LEX2073I,EN^LEX2073J,EN^LEX2073K,END,SC
Q
BEG ; Mapping Definitions file 757.32
D MES^XPDUTL(" Installing Title 38 Mapping Definition")
N DA,DIK,LEXID,LEXIEN,LEXL,LEXT S LEXID="ASCD",LEXIEN=$O(^LEX(757.32,"B",LEXID,0)) I +LEXIEN>0 S DA=+LEXIEN,DIK="^LEX(757.32," D ^DIK
S LEXID="ASCD",LEXIEN=2,DA=2 I $D(^LEX(757.32,+LEXIEN,0)) S DA=+LEXIEN,DIK="^LEX(757.32," D ^DIK
S ^LEX(757.32,LEXIEN,0)="ASCD^ICD Diagnosis to Title 38 Disabilities"
S ^LEX(757.32,LEXIEN,1,0)="^757.322^2^2^3110104^^^"
S ^LEX(757.32,LEXIEN,1,1,0)="Map ICD-9-CM Service Connected Diagnosis to Title 38 Disabilities for the"
S ^LEX(757.32,LEXIEN,1,2,0)="Automated Service Connected Designation (ASCD) project"
S ^LEX(757.32,LEXIEN,2)="1^17"
S DA=+LEXIEN,DIK="^LEX(757.32," D IX1^DIK S (LEXL,LEXT)="",LEXIEN=0
F S LEXIEN=$O(^LEX(757.32,LEXIEN)) Q:+LEXIEN'>0 S LEXL=LEXIEN,LEXT=+($G(LEXT))+1
S $P(^LEX(757.32,0),"^",3)=LEXL,$P(^LEX(757.32,0),"^",4)=LEXT
Q
END ; Mapping Order
D MES^XPDUTL(" Calculating Title 38 Mapping Order")
N LEX,LEXCT,LEXFM,LEXFOR,LEXIEN,LEXIN,LEXLIM,LEXMA,LEXN0,LEXOR,LEXSRC,LEXTGT,LEXTO S LEXIEN=0,LEXLIM=12788,LEXSRC=""
F S LEXSRC=$O(^LEX(757.33,"ASRC","ASCD",LEXSRC)) Q:'$L(LEXSRC) D
. N LEX,LEXTGT K LEX S LEXTGT="" F S LEXTGT=$O(^LEX(757.33,"ASRC","ASCD",LEXSRC,LEXTGT)) Q:'$L(LEXTGT) D
. . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(^LEX(757.33,"ASRC","ASCD",LEXSRC,LEXTGT,LEXIEN)) Q:+LEXIEN'>0 D
. . . N LEXCT,LEXFM,LEXFOR,LEXIN,LEXMA,LEXN0,LEXOR,LEXTO Q:+LEXIEN<LEXLIM S LEXN0=$G(^LEX(757.33,+LEXIEN,0)) Q:$P(LEXN0,"^",4)'=2
. . . S LEXFM=$P(LEXN0,"^",2) Q:'$L(LEXFM) S LEXTO=$P(LEXN0,"^",3) Q:'$L(LEXTO) S LEXMA=$P(LEXN0,"^",5) Q:'$L(LEXMA)
. . . S LEXOR=$S(+LEXMA=0:2,+LEXMA>0:1,1:"") Q:'$L(LEXOR) S LEXCT=+($O(LEX(" "),-1))+1,LEX(0)=LEXCT
. . . S LEX(LEXCT)=LEXFM_"^"_LEXTO_"^"_LEXMA_"^"_LEXIEN,LEX("O",+LEXOR,LEXTO,LEXCT,LEXIEN)=""
. I $D(LEX) D
. . N LEXCT,LEXFOR,LEXIEN,LEXIN,LEXMA,LEXOR,LEXTO S LEXOR=0 F LEXMA=1,2 D
. . . N LEXCT,LEXTO S LEXCT=0,LEXTO="" F S LEXTO=$O(LEX("O",LEXMA,LEXTO)) Q:'$L(LEXTO) D
. . . . N LEXIN S LEXIN=0 F S LEXIN=$O(LEX("O",LEXMA,LEXTO,LEXIN)) Q:+LEXIN'>0 D
. . . . . N LEXIEN S LEXIEN=0 F S LEXIEN=$O(LEX("O",LEXMA,LEXTO,LEXIN,LEXIEN)) Q:+LEXIEN'>0 D
. . . . . . N LEXFOR S LEXCT=LEXCT+1,LEXOR=LEXOR+1,LEXFOR=$P($G(^LEX(757.33,+LEXIEN,3)),"^",1) Q:+LEXFOR'>0 Q:+LEXOR'>0
. . . . . . S:LEXFOR'=LEXOR $P(^LEX(757.33,+LEXIEN,3),"^",1)=LEXOR
Q
SC ; Source and Categories
N DA,DIK,LEXCA,LEXCAE,LEXCC,LEXEX,LEXFD,LEXIS,LEXND,LEXSI,LEXSR,LEXSRE,LEXSRN S LEXCC=0,LEXCA=497 Q:'$D(^LEX(757.13,LEXCA,0))
S LEXCAE="Service Connected Diagnosis",LEXSR=4 Q:'$D(^LEX(757.14,LEXSR,0)) S LEXSRE="ASCD",LEXSRN="Automated Service Connected Designation"
D MES^XPDUTL(" Adding Source and Source Category")
S LEXSI=0 F S LEXSI=$O(^LEX(757.02,"ASRC","SCC",LEXSI)) Q:+LEXSI'>0 D
. N LEXND,LEXEX,DA,DIK,LEXFD,LEXIS S LEXND=$G(^LEX(757.02,+LEXSI,0)) Q:$P(LEXND,U,3)'=17
. S LEXEX=+LEXND Q:'$D(^LEX(757.01,+LEXEX,0)) Q:'$D(^LEX(757.01,+LEXEX,1))
. S DA=LEXEX,DIK="^LEX(757.01,"
. K LEXFD S LEXIS=LEXEX_",",LEXFD(757.01,LEXIS,15)=$G(LEXCA),LEXFD(757.01,LEXIS,16)=$G(LEXSR)
. D FILE^DIE("","LEXFD") S DA=LEXEX,DIK="^LEX(757.01," D IX1^DIK
. S LEXCC=LEXCC+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX2073B 4137 printed Apr 09, 2024@21:11:21 Page 2
LEX2073B ;ISL/KER - LEX*2.0*73 Post-Install - Data ;01/03/2011
+1 ;;2.0;LEXICON UTILITY;**73**;Sep 23, 1996;Build 10
+2 ;
+3 ; External Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; FILE^DIE ICR 2053
+8 ; ^DIK ICR 10013
+9 ; IX1^DIK ICR 10013
+10 ; BMES^XPDUTL ICR 10141
+11 ; MES^XPDUTL ICR 10141
+12 ;
+13 QUIT
EN ;
+1 NEW DA,DIK,LEX,LEXCA,LEXCAE,LEXCC,LEXCT,LEXEX,LEXFD,LEXFM,LEXFOR,LEXID,LEXIEN,LEXIN,LEXIS,LEXLIM,LEXMA,LEXN0,LEXND,LEXOR,LEXSI,LEXSR,LEXSRC,LEXSRE,LEXSRN,LEXTGT,LEXTO
+2 DO BMES^XPDUTL(" Updating Title 38 Terminology")
DO BEG
+3 DO MES^XPDUTL(" Adding Mixed Case Title 38 Expressions")
+4 DO EN^LEX2073C
DO EN^LEX2073D
DO EN^LEX2073E
DO EN^LEX2073F
DO EN^LEX2073G
+5 DO MES^XPDUTL(" Adding Inactive Title 38 Codes (historical)")
+6 DO EN^LEX2073H
DO EN^LEX2073I
DO EN^LEX2073J
DO EN^LEX2073K
DO END
DO SC
+7 QUIT
BEG ; Mapping Definitions file 757.32
+1 DO MES^XPDUTL(" Installing Title 38 Mapping Definition")
+2 NEW DA,DIK,LEXID,LEXIEN,LEXL,LEXT
SET LEXID="ASCD"
SET LEXIEN=$ORDER(^LEX(757.32,"B",LEXID,0))
IF +LEXIEN>0
SET DA=+LEXIEN
SET DIK="^LEX(757.32,"
DO ^DIK
+3 SET LEXID="ASCD"
SET LEXIEN=2
SET DA=2
IF $DATA(^LEX(757.32,+LEXIEN,0))
SET DA=+LEXIEN
SET DIK="^LEX(757.32,"
DO ^DIK
+4 SET ^LEX(757.32,LEXIEN,0)="ASCD^ICD Diagnosis to Title 38 Disabilities"
+5 SET ^LEX(757.32,LEXIEN,1,0)="^757.322^2^2^3110104^^^"
+6 SET ^LEX(757.32,LEXIEN,1,1,0)="Map ICD-9-CM Service Connected Diagnosis to Title 38 Disabilities for the"
+7 SET ^LEX(757.32,LEXIEN,1,2,0)="Automated Service Connected Designation (ASCD) project"
+8 SET ^LEX(757.32,LEXIEN,2)="1^17"
+9 SET DA=+LEXIEN
SET DIK="^LEX(757.32,"
DO IX1^DIK
SET (LEXL,LEXT)=""
SET LEXIEN=0
+10 FOR
SET LEXIEN=$ORDER(^LEX(757.32,LEXIEN))
if +LEXIEN'>0
QUIT
SET LEXL=LEXIEN
SET LEXT=+($GET(LEXT))+1
+11 SET $PIECE(^LEX(757.32,0),"^",3)=LEXL
SET $PIECE(^LEX(757.32,0),"^",4)=LEXT
+12 QUIT
END ; Mapping Order
+1 DO MES^XPDUTL(" Calculating Title 38 Mapping Order")
+2 NEW LEX,LEXCT,LEXFM,LEXFOR,LEXIEN,LEXIN,LEXLIM,LEXMA,LEXN0,LEXOR,LEXSRC,LEXTGT,LEXTO
SET LEXIEN=0
SET LEXLIM=12788
SET LEXSRC=""
+3 FOR
SET LEXSRC=$ORDER(^LEX(757.33,"ASRC","ASCD",LEXSRC))
if '$LENGTH(LEXSRC)
QUIT
Begin DoDot:1
+4 NEW LEX,LEXTGT
KILL LEX
SET LEXTGT=""
FOR
SET LEXTGT=$ORDER(^LEX(757.33,"ASRC","ASCD",LEXSRC,LEXTGT))
if '$LENGTH(LEXTGT)
QUIT
Begin DoDot:2
+5 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(^LEX(757.33,"ASRC","ASCD",LEXSRC,LEXTGT,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:3
+6 NEW LEXCT,LEXFM,LEXFOR,LEXIN,LEXMA,LEXN0,LEXOR,LEXTO
if +LEXIEN<LEXLIM
QUIT
SET LEXN0=$GET(^LEX(757.33,+LEXIEN,0))
if $PIECE(LEXN0,"^",4)'=2
QUIT
+7 SET LEXFM=$PIECE(LEXN0,"^",2)
if '$LENGTH(LEXFM)
QUIT
SET LEXTO=$PIECE(LEXN0,"^",3)
if '$LENGTH(LEXTO)
QUIT
SET LEXMA=$PIECE(LEXN0,"^",5)
if '$LENGTH(LEXMA)
QUIT
+8 SET LEXOR=$SELECT(+LEXMA=0:2,+LEXMA>0:1,1:"")
if '$LENGTH(LEXOR)
QUIT
SET LEXCT=+($ORDER(LEX(" "),-1))+1
SET LEX(0)=LEXCT
+9 SET LEX(LEXCT)=LEXFM_"^"_LEXTO_"^"_LEXMA_"^"_LEXIEN
SET LEX("O",+LEXOR,LEXTO,LEXCT,LEXIEN)=""
End DoDot:3
End DoDot:2
+10 IF $DATA(LEX)
Begin DoDot:2
+11 NEW LEXCT,LEXFOR,LEXIEN,LEXIN,LEXMA,LEXOR,LEXTO
SET LEXOR=0
FOR LEXMA=1,2
Begin DoDot:3
+12 NEW LEXCT,LEXTO
SET LEXCT=0
SET LEXTO=""
FOR
SET LEXTO=$ORDER(LEX("O",LEXMA,LEXTO))
if '$LENGTH(LEXTO)
QUIT
Begin DoDot:4
+13 NEW LEXIN
SET LEXIN=0
FOR
SET LEXIN=$ORDER(LEX("O",LEXMA,LEXTO,LEXIN))
if +LEXIN'>0
QUIT
Begin DoDot:5
+14 NEW LEXIEN
SET LEXIEN=0
FOR
SET LEXIEN=$ORDER(LEX("O",LEXMA,LEXTO,LEXIN,LEXIEN))
if +LEXIEN'>0
QUIT
Begin DoDot:6
+15 NEW LEXFOR
SET LEXCT=LEXCT+1
SET LEXOR=LEXOR+1
SET LEXFOR=$PIECE($GET(^LEX(757.33,+LEXIEN,3)),"^",1)
if +LEXFOR'>0
QUIT
if +LEXOR'>0
QUIT
+16 if LEXFOR'=LEXOR
SET $PIECE(^LEX(757.33,+LEXIEN,3),"^",1)=LEXOR
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT
SC ; Source and Categories
+1 NEW DA,DIK,LEXCA,LEXCAE,LEXCC,LEXEX,LEXFD,LEXIS,LEXND,LEXSI,LEXSR,LEXSRE,LEXSRN
SET LEXCC=0
SET LEXCA=497
if '$DATA(^LEX(757.13,LEXCA,0))
QUIT
+2 SET LEXCAE="Service Connected Diagnosis"
SET LEXSR=4
if '$DATA(^LEX(757.14,LEXSR,0))
QUIT
SET LEXSRE="ASCD"
SET LEXSRN="Automated Service Connected Designation"
+3 DO MES^XPDUTL(" Adding Source and Source Category")
+4 SET LEXSI=0
FOR
SET LEXSI=$ORDER(^LEX(757.02,"ASRC","SCC",LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:1
+5 NEW LEXND,LEXEX,DA,DIK,LEXFD,LEXIS
SET LEXND=$GET(^LEX(757.02,+LEXSI,0))
if $PIECE(LEXND,U,3)'=17
QUIT
+6 SET LEXEX=+LEXND
if '$DATA(^LEX(757.01,+LEXEX,0))
QUIT
if '$DATA(^LEX(757.01,+LEXEX,1))
QUIT
+7 SET DA=LEXEX
SET DIK="^LEX(757.01,"
+8 KILL LEXFD
SET LEXIS=LEXEX_","
SET LEXFD(757.01,LEXIS,15)=$GET(LEXCA)
SET LEXFD(757.01,LEXIS,16)=$GET(LEXSR)
+9 DO FILE^DIE("","LEXFD")
SET DA=LEXEX
SET DIK="^LEX(757.01,"
DO IX1^DIK
+10 SET LEXCC=LEXCC+1
End DoDot:1
+11 QUIT
