- 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 23, 2025@18:18:51 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
