Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICD1882B

ICD1882B.m

Go to the documentation of this file. 
  1. ICD1882B ;ALB/JDG - POST INSTALL ROUTINE-PART 2;8/1/2015
  1.  ;;18.0;DRG Grouper;**82**;Oct 20, 2000;Build 21
  1.  ;
  1.  N ICDX,ICDY,ICDHIST,ICDCSYS,ICDIEN,ICDPRE,ICDST,ICDCODE,ICDR,ICDEFF,ICDDX9,ICDDTTX,ICDF,ICDMDCF,ICDVAR,ICDCC
  1.  N ICDSTA,ICDI,ICDMIEN,ICDRGIEN,ICDFN,ICDDESC,ICDIX,ICDSTOP,ICDFILE,ICDFILE2,ICDAIDA,ICDMULT,ICDDAP,ICDCCMCC,ICDCCIEN
  1.  N ICDPDX,ICD103,ICD40,ICD14,ICD40IEN,ICD73IEN,ICD82,ICD821,ICD82T,ICDA,ICDB,ICDBLIEN,ICDBLK,ICDC,ICDCT,ICDDA,ICDDRGS,ICDDXCC
  1.  N ICDDXIEN,ICDEXCL,ICDEXIEN,ICDF2,ICDFI,ICDFILE,ICDFILE1,ICDFILE2,ICDFILE3,ICDFILE4,ICDFLAG,ICDFR,ICDFT,ICDMAC,ICDIEN2
  1.  N ICDLET,ICDMDDRG,ICDMDIEN,ICDONEI,ICDORCD,ICDOWN,ICDPCS,ICDPRIEN,ICDPRIM,ICDREC,ICDTO,ICDTY,ICDWIDTH,ICDXIEN,ICDYES,ICDWITH
  1.  N ICDN,ICDX,ICDIEN,ICDIEN9,ICDDX,ICDDAIEN,ICDFDA,ICDERR,ICDI,ICDDRG,ICDMDC,ICDBAD,ICDIDEN,ICDDX9,ICDMDC,ICDMDC24,ICDMDC25,ICDDRGN
  1.  N ICDORD,ICDDRG,ICDCC,ICDHAC,ICDA,ICDSUM,ICD73,ICDIDIEN
  1.  ;
  1. UP82 ;Set up #82 and #82.1 with IDENTIFIERS in ICDHLPD and ICDHLPO
  1.  ;
  1.  D BMES^XPDUTL("Starting #82 and #82.1 "_$$DTTIME)
  1.  S ICDSTOP=0
  1.  F ICDI="DX","PCS" D  Q:ICDSTOP
  1.  .S ICDFILE=$S(ICDI="DX":82,1:82.1),ICDN="",ICDFILE1=$S(ICDI="DX":"^ICDID",1:"^ICDIP")
  1.  .F  S ICDN=$O(^ICDLD82("ID",ICDI,ICDN)) Q:ICDN=""!(ICDSTOP)  S ICDX=^ICDLD82("ID",ICDI,ICDN) D
  1.  ..S ICDIEN=$O(@ICDFILE1@("B",ICDN,"")) I 'ICDIEN D
  1.  ...K ICDFDA,ICDERR S ICDFDA(ICDFILE,"+1,",.01)=ICDN D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
  1.  ..S ICDIEN=$O(@ICDFILE1@("B",ICDN,""))
  1.  ..K ICDFDA,ICDERR S ICDFDA(ICDFILE,ICDIEN_",",1)=ICDX D UPDATE^DIE("S","ICDFDA","","ICDERR") I $D(ICDERR) D ERR S ICDSTOP=1 Q
  1.  I '$O(^ICDID("B","o","")) D
  1.  .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
  1.  Q
  1.  ;
  1. 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 -->
  1.  D BMES^XPDUTL("Adding ICD-10 Identifiers to File #82 and #82.1 "_$$DTTIME)
  1.  S ICDDESC="",ICDDESC="",ICDSTOP=0,ICD82=+$G(^ICDLD82("MV",80)),ICD821=+$G(^ICDLD82("MV",80.1))
  1.  F  S ICDDESC=$O(^ICDLD82("ID10",ICDDESC)) Q:ICDDESC=""!(ICDSTOP)  D
  1.  .I $D(^ICDLD82("ID10",ICDDESC,1))!($D(^ICDLD82("ID10",ICDDESC,2))) D  ;DX
  1.  ..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
  1.  ...S ICD82T=$G(^ICDLD82("MV",80,ICDDESC)) S:ICD82T="" ICD82=ICD82+1,ICD82T=ICD82
  1.  .I $D(^ICDLD82("ID10",ICDDESC,3))!($D(^ICDLD82("ID10",ICDDESC,4))) D  ;PCS
  1.  ..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
  1.  ...S ICD82T=$G(^ICDLD82("MV",80.1,ICDDESC)) S:ICD82T="" ICD821=ICD821+1,ICD82T=ICD821
  1.  Q
  1.  ;
  1. UP8211 ;Populate File #82.11 from ^ICDLD82(82.11) - Procedure code Combinations/Clusters that came from Appendix E
  1.  ;
  1.  D BMES^XPDUTL("Starting Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
  1.  S ICDFLAG="" F  S ICDFLAG=$O(^ICDLD82(82.11,ICDFLAG)) Q:ICDFLAG=""  D
  1.  .S ICDIEN=$O(^ICDIP("C",ICDFLAG,"")) I 'ICDIEN D
  1.  ..;Add this flag to File 82.1 and then use the IEN to update #82.11
  1.  ..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
  1.  ..S ICDIEN=$O(^ICDIP("C",ICDFLAG,""))
  1.  .S ICDIDIEN=$O(^ICDIDP("B",ICDIEN,"")) I 'ICDIDIEN D
  1.  ..;Add IDENTIFIER CODE entry (IEN from 82.1 file) to File #82.11
  1.  ..K ICDFDA,ICDERR S ICDFDA(82.11,"+1,",.01)=ICDIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ..S ICDIDIEN=$O(^ICDIDP("B",ICDIEN,""))
  1.  .S ICDBLK=0 F  S ICDBLK=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK)) Q:'ICDBLK  D  S ICDONEI=0
  1.  ..K ICDFDA,ICDERR S ICDFDA(82.111,"+1,"_ICDIDIEN_",",.01)=ICDBLK D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ..S ICDBLIEN=$O(^ICDIDP(ICDIDIEN,"BL","B",ICDBLK,""))
  1.  ..;Each level 1 (One-Of) get all levels below
  1.  ..S ICDWITH="" F  S ICDWITH=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH)) Q:'ICDWITH  D
  1.  ...S ICDCODE="" F  S ICDCODE=$O(^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE)) Q:ICDCODE=""  D
  1.  ....S ICDMDDRG=^ICDLD82(82.11,ICDFLAG,ICDBLK,ICDWITH,ICDCODE)
  1.  ....S ICDPRIEN=$O(^ICD0("BA",ICDCODE_" ","")) I ICDPRIEN D  ;If in File #80.1
  1.  .....K ICDFDA,ICDERR S ICDFILE=$P("82.1111/82.1112/82.1113/82.1114/82.1115/","/",ICDWITH)
  1.  .....S ICDFDA(ICDFILE,"+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDPRIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  .....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
  1.  ......S:ICDTO=0 ICDTO=ICDFR F ICDDRG=ICDFR:1:ICDTO D
  1.  .......S ICDMDIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,"")) I 'ICDMDIEN D
  1.  ........K ICDFDA,ICDERR S ICDFDA("82.1116","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR Q
  1.  .......S ICDMDIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
  1.  .......S ICDRGIEN=$O(^ICDIDP(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",ICDDRG,"")) I ICDRGIEN="" D
  1.  ........K ICDFDA,ICDERR S ICDFDA("82.11161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDDRG D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ;
  1.  Q
  1.  ;
  1. UP8211B ;Now Populate Files #82.11 and #82.12 from clusters in ^ICDLD82("ID10") that came from the MDC files
  1.  ;
  1.  D BMES^XPDUTL("Adding Clusters to Files #82.11 and #82.12 "_$$DTTIME^ICD1882A)
  1.  S ICDDESC="" F  S ICDDESC=$O(^ICDLD82("ID10",ICDDESC)) Q:ICDDESC=""  D
  1.  .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
  1.  ..S ICDIEN=$O(@ICDFILE2@("C",ICDDESC,"")) I 'ICDIEN D
  1.  ...;Add this flag to File 82/82.1 and then use the IEN to update #82.11/12
  1.  ...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
  1.  ...S ICDIEN=$O(@ICDFILE2@("C",ICDDESC,""))
  1.  ..I ICDTY=1!(ICDTY=3) Q
  1.  ..S ICDIDIEN=$O(@ICDFILE4@("B",ICDIEN,"")) I 'ICDIDIEN D
  1.  ...;Add IDENTIFIER CODE entry (IEN from 82.1/82 file) to File #82.11/12
  1.  ...K ICDFDA,ICDERR S ICDFDA(ICDFILE3,"+1,",.01)=ICDIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ...S ICDIDIEN=$O(@ICDFILE4@("B",ICDIEN,""))
  1.  ..S ICDBLK=0 F  S ICDBLK=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK)) Q:ICDBLK=""  D
  1.  ...K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"1","+1,"_ICDIDIEN_",",.01)=ICDBLK D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ...S ICDBLIEN=$O(@ICDFILE4@(ICDIDIEN,"BL","B",ICDBLK,""))
  1.  ...;Each level 1 (One-Of) get all levels below
  1.  ...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
  1.  ....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
  1.  .....S ICDDX=ICDCODE I ICDTY=2 S ICDDX=$E(ICDCODE,1,3)_"."_$E(ICDCODE,4,$L(ICDCODE))
  1.  .....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
  1.  ......S ICDXIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,$P("ONE/WITH1/WITH2/WITH3/WITH4/","/",ICDWITH),"B",ICDPRIEN,"")) I 'ICDXIEN D
  1.  .......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
  1.  ......I ICDMDC'="" S ICDMDC=+ICDMDC S:ICDMDC=0 ICDMDC=98 S ICDMDIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,"")) I 'ICDMDIEN D
  1.  .......K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"16","+1,"_ICDBLIEN_","_ICDIDIEN_",",.01)=ICDMDC D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  .......S ICDMDIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC","B",ICDMDC,""))
  1.  .......S ICDDRG="" F  S ICDDRG=$O(^ICDLD82("ID10",ICDDESC,ICDTY,ICDBLK,ICDWITH,ICDCT,ICDCODE,"DRG",ICDDRG)) Q:ICDDRG=""  D
  1.  ........S ICDRGIEN=$O(@ICDFILE4@(ICDIDIEN,"BL",ICDBLIEN,"MDC",ICDMDIEN,"DRG","B",+ICDDRG,"")) I ICDRGIEN="" D
  1.  .........K ICDFDA,ICDERR S ICDFDA(ICDFILE3_"161","+1,"_ICDMDIEN_","_ICDBLIEN_","_ICDIDIEN_",",.01)=+ICDDRG D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  Q
  1.  ;
  1. UP8213 ;
  1.  D BMES^XPDUTL("Starting File #82.13 "_$$DTTIME^ICD1882A)
  1.  S ICDDX="" F  S ICDDX=$O(^ICDLD82("APPC","DX",ICDDX)) Q:ICDDX=""  D
  1.  .S ICDX=^ICDLD82("APPC","DX",ICDDX),ICDEXCL=$P(ICDX,U,2) D
  1.  ..S ICDIEN=$O(^ICD9("BA",ICDDX_" ","")) I 'ICDIEN D BMES^XPDUTL("ICD Code: "_ICDDX_" not in file #80") Q
  1.  ..;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
  1.  ..S ICDYES=0,ICDEXIEN=$O(^ICDCCEX("B",+ICDEXCL,"")) I ICDEXIEN="" D
  1.  ...K ICDFDA,ICDERR S ICDFDA(82.13,"+1,",.01)=+ICDEXCL D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ...S ICDEXIEN=$O(^ICDCCEX("B",+ICDEXCL,"")),ICDYES=1
  1.  ..K ICDFDA,ICDERR S ICDFDA(80,ICDIEN_",",1.11)=ICDEXIEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  ..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
  1.  ...K ICDFDA,ICDERR S ICDFDA(82.131,"+1,"_ICDEXIEN_",",.01)=ICD40IEN D UPDATE^DIE("S","ICDFDA",,"ICDERR") I $D(ICDERR) D ERR
  1.  Q
  1.  ;
  1. 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"
  1.  D BMES^XPDUTL("Setting Major O.R. flags in File# 80.1 Field 73 "_$$DTTIME^ICD1882A)
  1.  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
  1.  S ICDORCD=$P(^ICDIP(ICDORCD,0),U,1)
  1.  S ICDPCS="",ICDCT=0 F  S ICDPCS=$O(^ICDLD82(80.1,"MAJOR-OR",ICDPCS)) Q:ICDPCS=""  D
  1.  . D 8073^ICD1882A(80.1,ICDPCS,ICDORCD) S ICDCT=ICDCT+1
  1.  Q
  1.  ;
  1. ERR ;
  1.  I $D(ICDERR("DIERR",1,"PARAM","FILE")) D BMES^XPDUTL("FileMan error - FILE: "_ICDERR("DIERR",1,"PARAM","FILE"))
  1.  I $D(ICDERR("DIERR",1,"PARAM","IENS")) D BMES^XPDUTL("FileMan error - IENS: "_ICDERR("DIERR",1,"PARAM","IENS"))
  1.  I $D(ICDERR("DIERR",1,"PARAM","TEXT")) D BMES^XPDUTL("FileMan error - TEXT: "_ICDERR("DIERR",1,"PARAM","TEXT"))
  1.  Q
  1.  ;
  1.  ;if previously installed then delete files 80.5,80.6,82.11,82.12,82.13
  1. DELFILES ;
  1.  D MES^XPDUTL("Deleting entries in the file #80.5") D
  1.  . N DIK,DA S DIK="^ICDRS(" S DA=0 F  S DA=$O(^ICDRS(DA)) Q:+DA=0  D ^DIK
  1.  D MES^XPDUTL("Deleting entries in the file #80.6") D
  1.  . N DIK,DA S DIK="^ICDHAC(" S DA=0 F  S DA=$O(^ICDHAC(DA)) Q:+DA=0  D ^DIK
  1.  D MES^XPDUTL("Deleting entries in the file #82.11") D
  1.  . N DIK,DA S DIK="^ICDIDP(" S DA=0 F  S DA=$O(^ICDIDP(DA)) Q:+DA=0  D ^DIK
  1.  D MES^XPDUTL("Deleting entries in the file #82.12") D
  1.  . N DIK,DA S DIK="^ICDIDD(" S DA=0 F  S DA=$O(^ICDIDD(DA)) Q:+DA=0  D ^DIK
  1.  D MES^XPDUTL("Deleting entries in the file #82.13") D
  1.  . N DIK,DA S DIK="^ICDCCEX(" S DA=0 F  S DA=$O(^ICDCCEX(DA)) Q:+DA=0  D ^DIK
  1.  Q
  1.  ;
  1.  ;kill ^ICDLD82 after installation
  1. CLEANUP ;
  1.  D $system.Process.GlobalKillDisabled(0)
  1.  K ^ICDLD82
  1.  D $system.Process.GlobalKillDisabled(1)
  1.  Q
  1.  ;
  1. DTTIME() ;
  1.  S Y=$$NOW^XLFDT D DD^%DT
  1.  Q Y
  1.  ;
  1.  ;ICD1882B