ICD1882B ;ALB/JDG - POST INSTALL ROUTINE-PART 2;8/1/2015
;;18.0;DRG Grouper;**82**;Oct 20, 2000;Build 21
;
N ICDX,ICDY,ICDHIST,ICDCSYS,ICDIEN,ICDPRE,ICDST,ICDCODE,ICDR,ICDEFF,ICDDX9,ICDDTTX,ICDF,ICDMDCF,ICDVAR,ICDCC
N ICDSTA,ICDI,ICDMIEN,ICDRGIEN,ICDFN,ICDDESC,ICDIX,ICDSTOP,ICDFILE,ICDFILE2,ICDAIDA,ICDMULT,ICDDAP,ICDCCMCC,ICDCCIEN
N ICDPDX,ICD103,ICD40,ICD14,ICD40IEN,ICD73IEN,ICD82,ICD821,ICD82T,ICDA,ICDB,ICDBLIEN,ICDBLK,ICDC,ICDCT,ICDDA,ICDDRGS,ICDDXCC
N ICDDXIEN,ICDEXCL,ICDEXIEN,ICDF2,ICDFI,ICDFILE,ICDFILE1,ICDFILE2,ICDFILE3,ICDFILE4,ICDFLAG,ICDFR,ICDFT,ICDMAC,ICDIEN2
N ICDLET,ICDMDDRG,ICDMDIEN,ICDONEI,ICDORCD,ICDOWN,ICDPCS,ICDPRIEN,ICDPRIM,ICDREC,ICDTO,ICDTY,ICDWIDTH,ICDXIEN,ICDYES,ICDWITH
N ICDN,ICDX,ICDIEN,ICDIEN9,ICDDX,ICDDAIEN,ICDFDA,ICDERR,ICDI,ICDDRG,ICDMDC,ICDBAD,ICDIDEN,ICDDX9,ICDMDC,ICDMDC24,ICDMDC25,ICDDRGN
N ICDORD,ICDDRG,ICDCC,ICDHAC,ICDA,ICDSUM,ICD73,ICDIDIEN
;
UP82 ;Set up #82 and #82.1 with IDENTIFIERS in ICDHLPD and ICDHLPO
;
D BMES^XPDUTL("Starting #82 and #82.1 "_$$DTTIME)
S ICDSTOP=0
F ICDI="DX","PCS" D Q:ICDSTOP
.S ICDFILE=$S(ICDI="DX":82,1:82.1),ICDN="",ICDFILE1=$S(ICDI="DX":"^ICDID",1:"^ICDIP")
.F S ICDN=$O(^ICDLD82("ID",ICDI,ICDN)) Q:ICDN=""!(ICDSTOP) S ICDX=^ICDLD82("ID",ICDI,ICDN) D
..S ICDIEN=$O(@ICDFILE1@("B",ICDN,"")) I 'ICDIEN D
...K ICDFDA,ICDERR S ICDFDA(ICDFILE,"+1,",.01)=ICDN D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
..S ICDIEN=$O(@ICDFILE1@("B",ICDN,""))
..K ICDFDA,ICDERR S ICDFDA(ICDFILE,ICDIEN_",",1)=ICDX D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
I '$O(^ICDID("B","o","")) D
.K ICDFDA,ICDERR S ICDFDA(82,"+1,",.01)="o" S ICDFDA(82,"+1,",1)="ovary" D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
Q
;
UP82ADD ;Then add ICD-10 IDENTIFIERS extracted from MDC files to Files #82 and #82.1
;First, numerically assign new Identifier Codes in range 10 -->
D BMES^XPDUTL("Adding ICD-10 Identifiers to File #82 and #82.1 "_$$DTTIME)
S ICDDESC="",ICDDESC="",ICDSTOP=0,ICD82=+$G(^ICDLD82("MV",80)),ICD821=+$G(^ICDLD82("MV",80.1))
F S ICDDESC=$O(^ICDLD82("ID10",ICDDESC)) Q:ICDDESC=""!(ICDSTOP) D
.I $D(^ICDLD82("ID10",ICDDESC,1))!($D(^ICDLD82("ID10",ICDDESC,2))) D ;DX
..I '$D(^ICDID("C",ICDDESC)) K ICDFDA,ICDERR D S ICDFDA(82,"+1,",.01)=ICD82T,ICDFDA(82,"+1,",1)=$P(ICDDESC,$C(13)) D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
...S ICD82T=$G(^ICDLD82("MV",80,ICDDESC)) S:ICD82T="" ICD82=ICD82+1,ICD82T=ICD82
.I $D(^ICDLD82("ID10",ICDDESC,3))!($D(^ICDLD82("ID10",ICDDESC,4))) D ;PCS
..I '$D(^ICDIP("C",ICDDESC)) K ICDFDA,ICDERR D S ICDFDA(82.1,"+1,",.01)=ICD82T,ICDFDA(82.1,"+1,",1)=$P(ICDDESC,$C(13)) D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
...S ICD82T=$G(^ICDLD82("MV",80.1,ICDDESC)) S:ICD82T="" ICD821=ICD821+1,ICD82T=ICD821
Q
;
UP8211 ;Populate File #82.11 from ^ICDLD82(82.11) - Procedure code Combinations/Clusters that came from Appendix E
;
D BMES^XPDUTL("Starting Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
S ICDFLAG="" F S ICDFLAG=$O(^ICDLD82(82.11,ICDFLAG)) Q:ICDFLAG="" D
.S ICDIEN=$O(^ICDIP("C",ICDFLAG,"")) I 'ICDIEN D
..;Add this flag to File 82.1 and then use the IEN to update #82.11
..K ICDFDA,ICDERR S ICDIEN=$O(^ICDIP("B","A"),-1)+1,ICDFDA(82.1,"+1,",.01)=ICDIEN,ICDFDA(82.1,"+1,",1)=ICDFLAG D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
..S ICDIEN=$O(^ICDIP("C",ICDFLAG,""))
.S ICDIDIEN=$O(^ICDIDP("B",ICDIEN,"")) I 'ICDIDIEN D
..;Add IDENTIFIER CODE entry (IEN from 82.1 file) to File #82.11
..K ICDFDA,ICDERR S ICDFDA(82.11,"+1,",.01)=ICDIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
..S ICDIDIEN=$O(^ICDIDP("B",ICDIEN,""))
.S ICDBLK=0 F S ICDBLK=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK)) Q:'ICDBLK D S ICDONEI=0
..K ICDFDA,ICDERR S ICDFDA(82.111,"+1,"_ICDIDIEN_",",.01)=ICDBLK D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
..S ICDBLIEN=$O(^ICDIDP(ICDIDIEN,"BL","B",ICDBLK,""))
..;Each level 1 (One-Of) get all levels below
..S ICDWITH="" F S ICDWITH=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH)) Q:'ICDWITH D
...S ICDCODE="" F S ICDCODE=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE)) Q:ICDCODE="" D
....S ICDMDDRG=^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE)
....S ICDPRIEN=$O(^ICD0("BA",ICDCODE_" ","")) I ICDPRIEN D ;If in File #80.1
.....K ICDFDA,ICDERR S ICDFILE=$P("82.1111/82.1112/82.1113/82.1114/82.1115/","/",ICDWITH)
.....S ICDFDA(ICDFILE,"+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDPRIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
.....F ICDI=1:2 S ICDMDC=+$P(ICDMDDRG,U,ICDI) Q:ICDMDC=0 S ICDDRGS=$P(ICDMDDRG,U,ICDI+1) I ICDDRGS'="" S ICDFR=+$P(ICDDRGS,"-",1),ICDTO=+$P(ICDDRGS,"-",2) D
......S:ICDTO=0 ICDTO=ICDFR F ICDDRG=ICDFR:1:ICDTO D
.......S ICDMDIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,"")) I 'ICDMDIEN D
........K ICDFDA,ICDERR S ICDFDA("82.1116","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR Q
.......S ICDMDIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
.......S ICDRGIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",ICDDRG,"")) I ICDRGIEN="" D
........K ICDFDA,ICDERR S ICDFDA("82.11161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDDRG D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
;
Q
;
UP8211B ;Now Populate Files #82.11 and #82.12 from clusters in ^ICDLD82("ID10") that came from the MDC files
;
D BMES^XPDUTL("Adding Clusters to Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
S ICDDESC="" F S ICDDESC=$O(^ICDLD82("ID10",ICDDESC)) Q:ICDDESC="" D
.F ICDTY=1:1:4 I $D(^ICDLD82("ID10",ICDDESC,ICDTY)) S ICDFILE=$S(ICDTY=1!(ICDTY=2):82,1:82.1),ICDFILE2=$S(ICDTY=1!(ICDTY=2):"^ICDID",1:"^ICDIP"),ICDFILE3=$S(ICDTY=1!(ICDTY=2):82.12,1:82.11),ICDFILE4=$S(ICDTY=1!(ICDTY=2):"^ICDIDD",1:"^ICDIDP") D
..S ICDIEN=$O(@ICDFILE2@("C",ICDDESC,"")) I 'ICDIEN D
...;Add this flag to File 82/82.1 and then use the IEN to update #82.11/12
...K ICDFDA,ICDERR S ICDCODE=$O(@ICDFILE2@("B","*"),-1)+1,ICDFDA(ICDFILE,"+1,",.01)=ICDCODE,ICDFDA(ICDFILE,"+1,",1)=ICDDESC D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
...S ICDIEN=$O(@ICDFILE2@("C",ICDDESC,""))
..I ICDTY=1!(ICDTY=3) Q
..S ICDIDIEN=$O(@ICDFILE4@("B",ICDIEN,"")) I 'ICDIDIEN D
...;Add IDENTIFIER CODE entry (IEN from 82.1/82 file) to File #82.11/12
...K ICDFDA,ICDERR S ICDFDA(ICDFILE3,"+1,",.01)=ICDIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
...S ICDIDIEN=$O(@ICDFILE4@("B",ICDIEN,""))
..S ICDBLK=0 F S ICDBLK=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK)) Q:ICDBLK="" D
...K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"1","+1,"_ICDIDIEN_",",.01)=ICDBLK D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
...S ICDBLIEN=$O(@ICDFILE4@(ICDIDIEN,"BL","B",ICDBLK,""))
...;Each level 1 (One-Of) get all levels below
...S ICDWITH="" F S ICDWITH=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH)) Q:ICDWITH="" S ICDCT="" F S ICDCT=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT)) Q:ICDCT="" D
....S ICDCODE="" F S ICDCODE=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE)) Q:ICDCODE="" S ICDX=^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE),ICDMDC=$P(ICDX,U,1) D
.....S ICDDX=ICDCODE I ICDTY=2 S ICDDX=$E(ICDCODE,1,3)_"."_$E(ICDCODE,4,$L(ICDCODE))
.....S:ICDTY=4 ICDPRIEN=$O(^ICD0("BA",ICDDX_" ","")) S:ICDTY=2 ICDPRIEN=$O(^ICD9("BA",ICDDX_" ","")) I ICDPRIEN D ;If in File #80.1/80
......S ICDXIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,$P("ONE/WITH1/WITH2/WITH3/WITH4/","/",ICDWITH),"B",ICDPRIEN,"")) I 'ICDXIEN D
.......K ICDFDA,ICDERR S ICDFDA(ICDFILE3_$P("11/12/13/14/15/","/",ICDWITH),"+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDPRIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
......I ICDMDC'="" S ICDMDC=+ICDMDC S:ICDMDC=0 ICDMDC=98 S ICDMDIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,"")) I 'ICDMDIEN D
.......K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"16","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
.......S ICDMDIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
.......S ICDDRG="" F S ICDDRG=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE,"DRG",ICDDRG)) Q:ICDDRG="" D
........S ICDRGIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",+ICDDRG,"")) I ICDRGIEN="" D
.........K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=+ICDDRG D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
Q
;
UP8213 ;
D BMES^XPDUTL("Starting File #82.13 "_$$DTTIME^ICD1882A)
S ICDDX="" F S ICDDX=$O(^ICDLD82("APPC","DX",ICDDX)) Q:ICDDX="" D
.S ICDX=^ICDLD82("APPC","DX",ICDDX),ICDEXCL=$P(ICDX,U,2) D
..S ICDIEN=$O(^ICD9("BA",ICDDX_" ","")) I 'ICDIEN D BMES^XPDUTL("ICD Code: "_ICDDX_" not in file #80") Q
..;S ICDNODE=0 F S ICDNODE=$O(^ICDCCEX(ICDEXCL,1,ICDNODE,"")) Q:'ICDNODE K DA S DA=ICDNODE,DA(1)=ICDEXCL,DIK="^ICDCCEX("_DA(1)_"," D ^DIK Q
..S ICDYES=0,ICDEXIEN=$O(^ICDCCEX("B",+ICDEXCL,"")) I ICDEXIEN="" D
...K ICDFDA,ICDERR S ICDFDA(82.13,"+1,",.01)=+ICDEXCL D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
...S ICDEXIEN=$O(^ICDCCEX("B",+ICDEXCL,"")),ICDYES=1
..K ICDFDA,ICDERR S ICDFDA(80,ICDIEN_",",1.11)=ICDEXIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
..I ICDYES S ICDDXCC="" F S ICDDXCC=$O(^ICDLD82("APPC","PDX",ICDEXCL,ICDDXCC)) Q:ICDDXCC="" I ICDDX'=ICDDXCC S ICD40IEN=$O(^ICD9("BA",ICDDXCC_" ","")) I ICD40IEN D
...K ICDFDA,ICDERR S ICDFDA(82.131,"+1,"_ICDEXIEN_",",.01)=ICD40IEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
Q
;
MAJOROR ;
;This sets up ICD-10 Identifer 80 (Major O.R. Procedures) in Multiple 73 of #80.1 for all Procedure Codes that are neither "PROSTATIC" "y" nor "NONEXTENSIVE" "z"
D BMES^XPDUTL("Setting Major O.R. flags in File# 80.1 Field 73 "_$$DTTIME^ICD1882A)
S ICDORCD=$O(^ICDIP("C","MAJOR O.R. PROCEDURES","")) I ICDORCD="" D BMES^XPDUTL("IEN for MAJOR O.R. PROCEDURES not found in File #82.1") Q
S ICDORCD=$P(^ICDIP(ICDORCD,0),U,1)
S ICDPCS="",ICDCT=0 F S ICDPCS=$O(^ICDLD82(80.1,"MAJOR-OR",ICDPCS)) Q:ICDPCS="" D
. D 8073^ICD1882A(80.1,ICDPCS,ICDORCD) S ICDCT=ICDCT+1
Q
;
ERR ;
I $D(ICDERR("DIERR",1,"PARAM","FILE")) D BMES^XPDUTL("FileMan error - FILE: "_ICDERR("DIERR",1,"PARAM","FILE"))
I $D(ICDERR("DIERR",1,"PARAM","IENS")) D BMES^XPDUTL("FileMan error - IENS: "_ICDERR("DIERR",1,"PARAM","IENS"))
I $D(ICDERR("DIERR",1,"PARAM","TEXT")) D BMES^XPDUTL("FileMan error - TEXT: "_ICDERR("DIERR",1,"PARAM","TEXT"))
Q
;
;if previously installed then delete files 80.5,80.6,82.11,82.12,82.13
DELFILES ;
D MES^XPDUTL("Deleting entries in the file #80.5") D
. N DIK,DA S DIK="^ICDRS(" S DA=0 F S DA=$O(^ICDRS(DA)) Q:+DA=0 D ^DIK
D MES^XPDUTL("Deleting entries in the file #80.6") D
. N DIK,DA S DIK="^ICDHAC(" S DA=0 F S DA=$O(^ICDHAC(DA)) Q:+DA=0 D ^DIK
D MES^XPDUTL("Deleting entries in the file #82.11") D
. N DIK,DA S DIK="^ICDIDP(" S DA=0 F S DA=$O(^ICDIDP(DA)) Q:+DA=0 D ^DIK
D MES^XPDUTL("Deleting entries in the file #82.12") D
. N DIK,DA S DIK="^ICDIDD(" S DA=0 F S DA=$O(^ICDIDD(DA)) Q:+DA=0 D ^DIK
D MES^XPDUTL("Deleting entries in the file #82.13") D
. N DIK,DA S DIK="^ICDCCEX(" S DA=0 F S DA=$O(^ICDCCEX(DA)) Q:+DA=0 D ^DIK
Q
;
;kill ^ICDLD82 after installation
CLEANUP ;
D $system.Process.GlobalKillDisabled(0)
K ^ICDLD82
D $system.Process.GlobalKillDisabled(1)
Q
;
DTTIME() ;
S Y=$$NOW^XLFDT D DD^%DT
Q Y
;
;ICD1882B
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1882B 11685 printed Nov 22, 2024@16:59:22 Page 2
ICD1882B ;ALB/JDG - POST INSTALL ROUTINE-PART 2;8/1/2015
+1 ;;18.0;DRG Grouper;**82**;Oct 20, 2000;Build 21
+2 ;
+3 NEW ICDX,ICDY,ICDHIST,ICDCSYS,ICDIEN,ICDPRE,ICDST,ICDCODE,ICDR,ICDEFF,ICDDX9,ICDDTTX,ICDF,ICDMDCF,ICDVAR,ICDCC
+4 NEW ICDSTA,ICDI,ICDMIEN,ICDRGIEN,ICDFN,ICDDESC,ICDIX,ICDSTOP,ICDFILE,ICDFILE2,ICDAIDA,ICDMULT,ICDDAP,ICDCCMCC,ICDCCIEN
+5 NEW ICDPDX,ICD103,ICD40,ICD14,ICD40IEN,ICD73IEN,ICD82,ICD821,ICD82T,ICDA,ICDB,ICDBLIEN,ICDBLK,ICDC,ICDCT,ICDDA,ICDDRGS,ICDDXCC
+6 NEW ICDDXIEN,ICDEXCL,ICDEXIEN,ICDF2,ICDFI,ICDFILE,ICDFILE1,ICDFILE2,ICDFILE3,ICDFILE4,ICDFLAG,ICDFR,ICDFT,ICDMAC,ICDIEN2
+7 NEW ICDLET,ICDMDDRG,ICDMDIEN,ICDONEI,ICDORCD,ICDOWN,ICDPCS,ICDPRIEN,ICDPRIM,ICDREC,ICDTO,ICDTY,ICDWIDTH,ICDXIEN,ICDYES,ICDWITH
+8 NEW ICDN,ICDX,ICDIEN,ICDIEN9,ICDDX,ICDDAIEN,ICDFDA,ICDERR,ICDI,ICDDRG,ICDMDC,ICDBAD,ICDIDEN,ICDDX9,ICDMDC,ICDMDC24,ICDMDC25,ICDDRGN
+9 NEW ICDORD,ICDDRG,ICDCC,ICDHAC,ICDA,ICDSUM,ICD73,ICDIDIEN
+10 ;
UP82 ;Set up #82 and #82.1 with IDENTIFIERS in ICDHLPD and ICDHLPO
+1 ;
+2 DO BMES^XPDUTL("Starting #82 and #82.1 "_$$DTTIME)
+3 SET ICDSTOP=0
+4 FOR ICDI="DX","PCS"
Begin DoDot:1
+5 SET ICDFILE=$SELECT(ICDI="DX":82,1:82.1)
SET ICDN=""
SET ICDFILE1=$SELECT(ICDI="DX":"^ICDID",1:"^ICDIP")
+6 FOR
SET ICDN=$ORDER(^ICDLD82("ID",ICDI,ICDN))
if ICDN=""!(ICDSTOP)
QUIT
SET ICDX=^ICDLD82("ID",ICDI,ICDN)
Begin DoDot:2
+7 SET ICDIEN=$ORDER(@ICDFILE1@("B",ICDN,""))
IF 'ICDIEN
Begin DoDot:3
+8 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE,"+1,",.01)=ICDN
DO UPDATE^DIE("S","ICDFDA","","ICDERR")
IF $DATA(ICDERR)
DO ERR
SET ICDSTOP=1
QUIT
End DoDot:3
+9 SET ICDIEN=$ORDER(@ICDFILE1@("B",ICDN,""))
+10 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE,ICDIEN_",",1)=ICDX
DO UPDATE^DIE("S","ICDFDA","","ICDERR")
IF $DATA(ICDERR)
DO ERR
SET ICDSTOP=1
QUIT
End DoDot:2
End DoDot:1
if ICDSTOP
QUIT
+11 IF '$ORDER(^ICDID("B","o",""))
Begin DoDot:1
+12 KILL ICDFDA,ICDERR
SET ICDFDA(82,"+1,",.01)="o"
SET ICDFDA(82,"+1,",1)="ovary"
DO UPDATE^DIE("S","ICDFDA","","ICDERR")
IF $DATA(ICDERR)
DO ERR
SET ICDSTOP=1
QUIT
End DoDot:1
+13 QUIT
+14 ;
UP82ADD ;Then add ICD-10 IDENTIFIERS extracted from MDC files to Files #82 and #82.1
+1 ;First, numerically assign new Identifier Codes in range 10 -->
+2 DO BMES^XPDUTL("Adding ICD-10 Identifiers to File #82 and #82.1 "_$$DTTIME)
+3 SET ICDDESC=""
SET ICDDESC=""
SET ICDSTOP=0
SET ICD82=+$GET(^ICDLD82("MV",80))
SET ICD821=+$GET(^ICDLD82("MV",80.1))
+4 FOR
SET ICDDESC=$ORDER(^ICDLD82("ID10",ICDDESC))
if ICDDESC=""!(ICDSTOP)
QUIT
Begin DoDot:1
+5 ;DX
IF $DATA(^ICDLD82("ID10",ICDDESC,1))!($DATA(^ICDLD82("ID10",ICDDESC,2)))
Begin DoDot:2
+6 IF '$DATA(^ICDID("C",ICDDESC))
KILL ICDFDA,ICDERR
Begin DoDot:3
+7 SET ICD82T=$GET(^ICDLD82("MV",80,ICDDESC))
if ICD82T=""
SET ICD82=ICD82+1
SET ICD82T=ICD82
End DoDot:3
SET ICDFDA(82,"+1,",.01)=ICD82T
SET ICDFDA(82,"+1,",1)=$PIECE(ICDDESC,$CHAR(13))
DO UPDATE^DIE("S","ICDFDA","","ICDERR")
IF $DATA(ICDERR)
DO ERR
SET ICDSTOP=1
QUIT
End DoDot:2
+8 ;PCS
IF $DATA(^ICDLD82("ID10",ICDDESC,3))!($DATA(^ICDLD82("ID10",ICDDESC,4)))
Begin DoDot:2
+9 IF '$DATA(^ICDIP("C",ICDDESC))
KILL ICDFDA,ICDERR
Begin DoDot:3
+10 SET ICD82T=$GET(^ICDLD82("MV",80.1,ICDDESC))
if ICD82T=""
SET ICD821=ICD821+1
SET ICD82T=ICD821
End DoDot:3
SET ICDFDA(82.1,"+1,",.01)=ICD82T
SET ICDFDA(82.1,"+1,",1)=$PIECE(ICDDESC,$CHAR(13))
DO UPDATE^DIE("S","ICDFDA","","ICDERR")
IF $DATA(ICDERR)
DO ERR
SET ICDSTOP=1
QUIT
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
UP8211 ;Populate File #82.11 from ^ICDLD82(82.11) - Procedure code Combinations/Clusters that came from Appendix E
+1 ;
+2 DO BMES^XPDUTL("Starting Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
+3 SET ICDFLAG=""
FOR
SET ICDFLAG=$ORDER(^ICDLD82(82.11,ICDFLAG))
if ICDFLAG=""
QUIT
Begin DoDot:1
+4 SET ICDIEN=$ORDER(^ICDIP("C",ICDFLAG,""))
IF 'ICDIEN
Begin DoDot:2
+5 ;Add this flag to File 82.1 and then use the IEN to update #82.11
+6 KILL ICDFDA,ICDERR
SET ICDIEN=$ORDER(^ICDIP("B","A"),-1)+1
SET ICDFDA(82.1,"+1,",.01)=ICDIEN
SET ICDFDA(82.1,"+1,",1)=ICDFLAG
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+7 SET ICDIEN=$ORDER(^ICDIP("C",ICDFLAG,""))
End DoDot:2
+8 SET ICDIDIEN=$ORDER(^ICDIDP("B",ICDIEN,""))
IF 'ICDIDIEN
Begin DoDot:2
+9 ;Add IDENTIFIER CODE entry (IEN from 82.1 file) to File #82.11
+10 KILL ICDFDA,ICDERR
SET ICDFDA(82.11,"+1,",.01)=ICDIEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+11 SET ICDIDIEN=$ORDER(^ICDIDP("B",ICDIEN,""))
End DoDot:2
+12 SET ICDBLK=0
FOR
SET ICDBLK=$ORDER(^ICDLD82(82.11,ICDFLAG,ICDBLK))
if 'ICDBLK
QUIT
Begin DoDot:2
+13 KILL ICDFDA,ICDERR
SET ICDFDA(82.111,"+1,"_ICDIDIEN_",",.01)=ICDBLK
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+14 SET ICDBLIEN=$ORDER(^ICDIDP(ICDIDIEN,"BL","B",ICDBLK,""))
+15 ;Each level 1 (One-Of) get all levels below
+16 SET ICDWITH=""
FOR
SET ICDWITH=$ORDER(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH))
if 'ICDWITH
QUIT
Begin DoDot:3
+17 SET ICDCODE=""
FOR
SET ICDCODE=$ORDER(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE))
if ICDCODE=""
QUIT
Begin DoDot:4
+18 SET ICDMDDRG=^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE)
+19 ;If in File #80.1
SET ICDPRIEN=$ORDER(^ICD0("BA",ICDCODE_" ",""))
IF ICDPRIEN
Begin DoDot:5
+20 KILL ICDFDA,ICDERR
SET ICDFILE=$PIECE("82.1111/82.1112/82.1113/82.1114/82.1115/","/",ICDWITH)
+21 SET ICDFDA(ICDFILE,"+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDPRIEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+22 FOR ICDI=1:2
SET ICDMDC=+$PIECE(ICDMDDRG,U,ICDI)
if ICDMDC=0
QUIT
SET ICDDRGS=$PIECE(ICDMDDRG,U,ICDI+1)
IF ICDDRGS'=""
SET ICDFR=+$PIECE(ICDDRGS,"-",1)
SET ICDTO=+$PIECE(ICDDRGS,"-",2)
Begin DoDot:6
+23 if ICDTO=0
SET ICDTO=ICDFR
FOR ICDDRG=ICDFR:1:ICDTO
Begin DoDot:7
+24 SET ICDMDIEN=$ORDER(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
IF 'ICDMDIEN
Begin DoDot:8
+25 KILL ICDFDA,ICDERR
SET ICDFDA("82.1116","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
QUIT
End DoDot:8
+26 SET ICDMDIEN=$ORDER(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
+27 SET ICDRGIEN=$ORDER(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",ICDDRG,""))
IF ICDRGIEN=""
Begin DoDot:8
+28 KILL ICDFDA,ICDERR
SET ICDFDA("82.11161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDDRG
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
SET ICDONEI=0
End DoDot:1
+29 ;
+30 QUIT
+31 ;
UP8211B ;Now Populate Files #82.11 and #82.12 from clusters in ^ICDLD82("ID10") that came from the MDC files
+1 ;
+2 DO BMES^XPDUTL("Adding Clusters to Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
+3 SET ICDDESC=""
FOR
SET ICDDESC=$ORDER(^ICDLD82("ID10",ICDDESC))
if ICDDESC=""
QUIT
Begin DoDot:1
+4 FOR ICDTY=1:1:4
IF $DATA(^ICDLD82("ID10",ICDDESC,ICDTY))
SET ICDFILE=$SELECT(ICDTY=1!(ICDTY=2):82,1:82.1)
SET ICDFILE2=$SELECT(ICDTY=1!(ICDTY=2):"^ICDID",1:"^ICDIP")
SET ICDFILE3=$SELECT(ICDTY=1!(ICDTY=2):82.12,1:82.11)
SET ICDFILE4=$SELECT(ICDTY=1!(ICDTY=2):"^ICDIDD",1:"^ICDIDP")
Begin DoDot:2
+5 SET ICDIEN=$ORDER(@ICDFILE2@("C",ICDDESC,""))
IF 'ICDIEN
Begin DoDot:3
+6 ;Add this flag to File 82/82.1 and then use the IEN to update #82.11/12
+7 KILL ICDFDA,ICDERR
SET ICDCODE=$ORDER(@ICDFILE2@("B","*"),-1)+1
SET ICDFDA(ICDFILE,"+1,",.01)=ICDCODE
SET ICDFDA(ICDFILE,"+1,",1)=ICDDESC
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+8 SET ICDIEN=$ORDER(@ICDFILE2@("C",ICDDESC,""))
End DoDot:3
+9 IF ICDTY=1!(ICDTY=3)
QUIT
+10 SET ICDIDIEN=$ORDER(@ICDFILE4@("B",ICDIEN,""))
IF 'ICDIDIEN
Begin DoDot:3
+11 ;Add IDENTIFIER CODE entry (IEN from 82.1/82 file) to File #82.11/12
+12 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE3,"+1,",.01)=ICDIEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+13 SET ICDIDIEN=$ORDER(@ICDFILE4@("B",ICDIEN,""))
End DoDot:3
+14 SET ICDBLK=0
FOR
SET ICDBLK=$ORDER(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK))
if ICDBLK=""
QUIT
Begin DoDot:3
+15 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE3_"1","+1,"_ICDIDIEN_",",.01)=ICDBLK
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+16 SET ICDBLIEN=$ORDER(@ICDFILE4@(ICDIDIEN,"BL","B",ICDBLK,""))
+17 ;Each level 1 (One-Of) get all levels below
+18 SET ICDWITH=""
FOR
SET ICDWITH=$ORDER(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH))
if ICDWITH=""
QUIT
SET ICDCT=""
FOR
SET ICDCT=$ORDER(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT))
if ICDCT=""
QUIT
Begin DoDot:4
+19 SET ICDCODE=""
FOR
SET ICDCODE=$ORDER(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE))
if ICDCODE=""
QUIT
SET ICDX=^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE)
SET ICDMDC=$PIECE(ICDX,U,1)
Begin DoDot:5
+20 SET ICDDX=ICDCODE
IF ICDTY=2
SET ICDDX=$EXTRACT(ICDCODE,1,3)_"."_$EXTRACT(ICDCODE,4,$LENGTH(ICDCODE))
+21 ;If in File #80.1/80
if ICDTY=4
SET ICDPRIEN=$ORDER(^ICD0("BA",ICDDX_" ",""))
if ICDTY=2
SET ICDPRIEN=$ORDER(^ICD9("BA",ICDDX_" ",""))
IF ICDPRIEN
Begin DoDot:6
+22 SET ICDXIEN=$ORDER(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,$PIECE("ONE/WITH1/WITH2/WITH3/WITH4/","/",ICDWITH),"B",ICDPRIEN,""))
IF 'ICDXIEN
Begin DoDot:7
+23 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE3_$PIECE("11/12/13/14/15/","/",ICDWITH),"+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDPRIEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
End DoDot:7
+24 IF ICDMDC'=""
SET ICDMDC=+ICDMDC
if ICDMDC=0
SET ICDMDC=98
SET ICDMDIEN=$ORDER(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
IF 'ICDMDIEN
Begin DoDot:7
+25 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE3_"16","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+26 SET ICDMDIEN=$ORDER(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
+27 SET ICDDRG=""
FOR
SET ICDDRG=$ORDER(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE,"DRG",ICDDRG))
if ICDDRG=""
QUIT
Begin DoDot:8
+28 SET ICDRGIEN=$ORDER(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",+ICDDRG,""))
IF ICDRGIEN=""
Begin DoDot:9
+29 KILL ICDFDA,ICDERR
SET ICDFDA(ICDFILE3_"161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=+ICDDRG
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
End DoDot:9
End DoDot:8
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
UP8213 ;
+1 DO BMES^XPDUTL("Starting File #82.13 "_$$DTTIME^ICD1882A)
+2 SET ICDDX=""
FOR
SET ICDDX=$ORDER(^ICDLD82("APPC","DX",ICDDX))
if ICDDX=""
QUIT
Begin DoDot:1
+3 SET ICDX=^ICDLD82("APPC","DX",ICDDX)
SET ICDEXCL=$PIECE(ICDX,U,2)
Begin DoDot:2
+4 SET ICDIEN=$ORDER(^ICD9("BA",ICDDX_" ",""))
IF 'ICDIEN
DO BMES^XPDUTL("ICD Code: "_ICDDX_" not in file #80")
QUIT
+5 ;S ICDNODE=0 F S ICDNODE=$O(^ICDCCEX(ICDEXCL,1,ICDNODE,"")) Q:'ICDNODE K DA S DA=ICDNODE,DA(1)=ICDEXCL,DIK="^ICDCCEX("_DA(1)_"," D ^DIK Q
+6 SET ICDYES=0
SET ICDEXIEN=$ORDER(^ICDCCEX("B",+ICDEXCL,""))
IF ICDEXIEN=""
Begin DoDot:3
+7 KILL ICDFDA,ICDERR
SET ICDFDA(82.13,"+1,",.01)=+ICDEXCL
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+8 SET ICDEXIEN=$ORDER(^ICDCCEX("B",+ICDEXCL,""))
SET ICDYES=1
End DoDot:3
+9 KILL ICDFDA,ICDERR
SET ICDFDA(80,ICDIEN_",",1.11)=ICDEXIEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
+10 IF ICDYES
SET ICDDXCC=""
FOR
SET ICDDXCC=$ORDER(^ICDLD82("APPC","PDX",ICDEXCL,ICDDXCC))
if ICDDXCC=""
QUIT
IF ICDDX'=ICDDXCC
SET ICD40IEN=$ORDER(^ICD9("BA",ICDDXCC_" ",""))
IF ICD40IEN
Begin DoDot:3
+11 KILL ICDFDA,ICDERR
SET ICDFDA(82.131,"+1,"_ICDEXIEN_",",.01)=ICD40IEN
DO UPDATE^DIE("S","ICDFDA",,"ICDERR")
IF $DATA(ICDERR)
DO ERR
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
MAJOROR ;
+1 ;This sets up ICD-10 Identifer 80 (Major O.R. Procedures) in Multiple 73 of #80.1 for all Procedure Codes that are neither "PROSTATIC" "y" nor "NONEXTENSIVE" "z"
+2 DO BMES^XPDUTL("Setting Major O.R. flags in File# 80.1 Field 73 "_$$DTTIME^ICD1882A)
+3 SET ICDORCD=$ORDER(^ICDIP("C","MAJOR O.R. PROCEDURES",""))
IF ICDORCD=""
DO BMES^XPDUTL("IEN for MAJOR O.R. PROCEDURES not found in File #82.1")
QUIT
+4 SET ICDORCD=$PIECE(^ICDIP(ICDORCD,0),U,1)
+5 SET ICDPCS=""
SET ICDCT=0
FOR
SET ICDPCS=$ORDER(^ICDLD82(80.1,"MAJOR-OR",ICDPCS))
if ICDPCS=""
QUIT
Begin DoDot:1
+6 DO 8073^ICD1882A(80.1,ICDPCS,ICDORCD)
SET ICDCT=ICDCT+1
End DoDot:1
+7 QUIT
+8 ;
ERR ;
+1 IF $DATA(ICDERR("DIERR",1,"PARAM","FILE"))
DO BMES^XPDUTL("FileMan error - FILE: "_ICDERR("DIERR",1,"PARAM","FILE"))
+2 IF $DATA(ICDERR("DIERR",1,"PARAM","IENS"))
DO BMES^XPDUTL("FileMan error - IENS: "_ICDERR("DIERR",1,"PARAM","IENS"))
+3 IF $DATA(ICDERR("DIERR",1,"PARAM","TEXT"))
DO BMES^XPDUTL("FileMan error - TEXT: "_ICDERR("DIERR",1,"PARAM","TEXT"))
+4 QUIT
+5 ;
+6 ;if previously installed then delete files 80.5,80.6,82.11,82.12,82.13
DELFILES ;
+1 DO MES^XPDUTL("Deleting entries in the file #80.5")
Begin DoDot:1
+2 NEW DIK,DA
SET DIK="^ICDRS("
SET DA=0
FOR
SET DA=$ORDER(^ICDRS(DA))
if +DA=0
QUIT
DO ^DIK
End DoDot:1
+3 DO MES^XPDUTL("Deleting entries in the file #80.6")
Begin DoDot:1
+4 NEW DIK,DA
SET DIK="^ICDHAC("
SET DA=0
FOR
SET DA=$ORDER(^ICDHAC(DA))
if +DA=0
QUIT
DO ^DIK
End DoDot:1
+5 DO MES^XPDUTL("Deleting entries in the file #82.11")
Begin DoDot:1
+6 NEW DIK,DA
SET DIK="^ICDIDP("
SET DA=0
FOR
SET DA=$ORDER(^ICDIDP(DA))
if +DA=0
QUIT
DO ^DIK
End DoDot:1
+7 DO MES^XPDUTL("Deleting entries in the file #82.12")
Begin DoDot:1
+8 NEW DIK,DA
SET DIK="^ICDIDD("
SET DA=0
FOR
SET DA=$ORDER(^ICDIDD(DA))
if +DA=0
QUIT
DO ^DIK
End DoDot:1
+9 DO MES^XPDUTL("Deleting entries in the file #82.13")
Begin DoDot:1
+10 NEW DIK,DA
SET DIK="^ICDCCEX("
SET DA=0
FOR
SET DA=$ORDER(^ICDCCEX(DA))
if +DA=0
QUIT
DO ^DIK
End DoDot:1
+11 QUIT
+12 ;
+13 ;kill ^ICDLD82 after installation
CLEANUP ;
+1
*** ERROR ***
DO $system.Process.GlobalKillDisabled(0)
+2 KILL ^ICDLD82
+3
*** ERROR ***
DO $system.Process.GlobalKillDisabled(1)
+4 QUIT
+5 ;
DTTIME() ;
+1 SET Y=$$NOW^XLFDT
DO DD^%DT
+2 QUIT Y
+3 ;
+4 ;ICD1882B
