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

ICD1869L.m

Go to the documentation of this file.
  1. ICD1869L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
  1. ;;18.0;DRG Grouper;**69**;Oct 20,2000;Build 4
  1. ;
  1. Q
  1. ;
  1. ; Update Dx code(s)
  1. ICDUPDDX ; update DX identifier(s)
  1. D BMES^XPDUTL(">>> UPDATING DX CODE 482.42 IDENTIFIER...")
  1. N LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
  1. S DIE="^ICD9(",DR="2///^S X=IDENT"
  1. F LINE=1:1 S LINEXX=$T(PROCUP1+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
  1. .S DA=ICDDXDA
  1. .S IDENT="k"
  1. .D ^DIE
  1. .Q
  1. D BMES^XPDUTL(">>> UPDATING DX CODE 779.84 IDENTIFIER...")
  1. N LINE,DXTXT,ICDDXDA1,DA,IDENT
  1. F LINE=1:1 S DXTXT=$T(PROCUP3+LINE) S ICDDXDA1=$P(DXTXT,";;",2) Q:ICDDXDA1="EXIT" D
  1. .S DA=ICDDXDA1
  1. .S IDENT="S"
  1. .D ^DIE
  1. .Q
  1. D BMES^XPDUTL(">>> UPDATING DX CODE V64.06 IDENTIFIER...")
  1. N LINE,DXTXT,ICDDXDA4,DA,IDENT
  1. F LINE=1:1 S DXTXT=$T(PROCUP4+LINE) S ICDDXDA4=$P(DXTXT,";;",2) Q:ICDDXDA4="EXIT" D
  1. .S DA=ICDDXDA4
  1. .S IDENT="S"
  1. .D ^DIE
  1. .Q
  1. D BMES^XPDUTL(">>> UPDATING DX CODE V18.0 IDENTIFIER...")
  1. N LINE,DXTXT,ICDDXDA2,DA,IDENT
  1. F LINE=1:1 S DXTXT=$T(PROCUP5+LINE) S ICDDXDA2=$P(DXTXT,";;",2) Q:ICDDXDA2="EXIT" D
  1. .S DA=ICDDXDA2
  1. .S IDENT="S"
  1. .D ^DIE
  1. .Q
  1. Q
  1. ;
  1. ;
  1. ; Update Px code(s)
  1. ICDUPDPX ; Update Px identifier(s)
  1. D BMES^XPDUTL(">>> UPDATING PX CODE 32.20 IDENTIFIER...")
  1. N LINE,LINEXX,ICDPXDA3,DA,IDENT,DR,DIE
  1. F LINE=1:1 S LINEXX=$T(PROCUP2+LINE) S ICDPXDA3=$P(LINEXX,";;",2) Q:ICDPXDA3="EXIT" D
  1. .S DIE="^ICD0(",DR="2///^S X=IDENT"
  1. .S DA=ICDPXDA3
  1. .S IDENT="O"
  1. .D ^DIE
  1. Q
  1. ;
  1. ;
  1. ICDECUP1 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.20
  1. N ICDSAVXC,ICDXC,ICDDX
  1. S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
  1. S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
  1. S $P(^DD(45.89,.01,0),U,2)=ICDXC
  1. F ICDDX=294.20 D
  1. .S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
  1. .Q:+Y'>0
  1. .I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
  1. ..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
  1. .S DIC="^DIC(45.89,",DIC(0)=""
  1. .S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
  1. .K DO D FILE^DICN
  1. .I +Y<0 D Q
  1. ..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
  1. .D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
  1. S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
  1. K DIC,DIE,DA,DR,Y,X
  1. Q
  1. ;
  1. ;
  1. ICDECUP2 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.21
  1. N ICDSAVXC,ICDXC,ICDDX
  1. S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
  1. S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
  1. S $P(^DD(45.89,.01,0),U,2)=ICDXC
  1. F ICDDX=294.21 D
  1. .S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
  1. .Q:+Y'>0
  1. .I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
  1. ..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
  1. .S DIC="^DIC(45.89,",DIC(0)=""
  1. .S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
  1. .K DO D FILE^DICN
  1. .I +Y<0 D Q
  1. ..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
  1. .D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
  1. S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
  1. K DIC,DIE,DA,DR,Y,X
  1. Q
  1. ;
  1. ;
  1. PROCUP1 ;
  1. ;;14734
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP2 ;
  1. ;;4369
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP3 ;
  1. ;;14156
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP4 ;
  1. ;;14211
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP5 ;
  1. ;;11396
  1. ;;EXIT