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

ICD1862L.m

Go to the documentation of this file.
  1. ICD1862L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
  1. ;;18.0;DRG Grouper;**62**;Oct 20,2000;Build 7
  1. ;
  1. Q
  1. ;
  1. ; Update Dx code(s)
  1. ICDUPDDX ; update DX identifier(s)
  1. D BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
  1. N LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
  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 DIE="^ICD9("
  1. .S IDENT="k"
  1. .S DR="2///^S X=IDENT"
  1. .D ^DIE
  1. ;
  1. ;
  1. ;DX - update DX MDC24 field
  1. D BMES^XPDUTL(">>> UPDATING DX CODE 860.0...")
  1. N LINE,LINEXX,ICDDXDA,DA,DIE,NMDC24C,DR
  1. F LINE=1:1 S LINEXX=$T(PROCUP5+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
  1. .S DA=ICDDXDA
  1. .S DIE="^ICD9("
  1. .S NMDC24C=2
  1. .S DR="5.7///^S X=NMDC24C"
  1. .D ^DIE
  1. Q
  1. ;
  1. ;
  1. ; Update Px code(s)
  1. ICDUPDPX ; Update Px identifier(s)
  1. D BMES^XPDUTL(">>> UPDATING PX CODE 31.1 MAJOR O.R. PROCEDURE...")
  1. N LINE,LINEXX,ICDPXDA3,DA,MAJOR
  1. S DIE="^ICD0(",DR="20///^S X=MAJOR"
  1. F LINE=1:1 S LINEXX=$T(PROCUP2+LINE) S ICDPXDA3=$P(LINEXX,";;",2) Q:ICDPXDA3="EXIT" D
  1. .S DA=ICDPXDA3
  1. .S MAJOR="9"
  1. .D ^DIE
  1. ;
  1. ; updating/replacing associated DRGs
  1. D BMES^XPDUTL(">>> UPDATING PX CODE 80.05 DRGs...")
  1. N ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDTXTTP
  1. F LINE=1:1 S LINEXX=$T(PROCUP3+LINE) S ICDTXT=$P(LINEXX,";;",2),ICDTXTFP=$P(ICDTXT,"^"),ICDTXTSP=$P(ICDTXT,"^",2),ICDTXTTP=$P(ICDTXT,"^",3),ICDDATE1=$P(ICDTXT,"^",4),MDC1=$P(ICDTXT,"^",5) Q:ICDTXT="EXIT" D
  1. .S ICDPXIENX=ICDTXTFP_" " ;DEBUG
  1. .S ICDDRGREP=ICDTXTTP
  1. .S ICDPXIEN=$O(^ICD0("AB",ICDPXIENX,""))
  1. .I +ICDPXIEN D ;DEBUG
  1. ..S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
  1. ..S ICDDRGNUM=ICDTXTSP S DRGIEN=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
  1. ..S ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGREP
  1. ..D UPDATE^DIE("","ICDFDA") K ICDFDA
  1. ;
  1. ; add associated DRGs
  1. D BMES^XPDUTL(">>> UPDATING PX CODE 81.05 DRGs...")
  1. N ICDPXIEN,ICDDRGIEN,ICDDATE1,MDC1,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDMDCLVL,ICDPXIENX,ICDDRGADD
  1. F LINE=1:1 S LINEXX=$T(PROCUP4+LINE) S ICDTXT=$P(LINEXX,";;",2),ICDTXTFP=$P(ICDTXT,"^"),ICDTXTSP=$P(ICDTXT,"^",2),ICDDATE1=$P(ICDTXT,"^",3),MDC1=$P(ICDTXT,"^",4) Q:ICDTXT="EXIT" D
  1. .S ICDMDCLVL=0
  1. .S ICDPXIENX=ICDTXTFP_" " ;DEBUG
  1. .S ICDDRGADD=ICDTXTSP
  1. .S ICDPXIEN=$O(^ICD0("AB",ICDPXIENX,""))
  1. .S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
  1. .F S ICDMDCLVL=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL)) Q:(ICDMDCLVL="")!($G(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL,0))=MDC1)
  1. .S ICDFDA(80.17111,"+1,"_ICDMDCLVL_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGADD
  1. .D UPDATE^DIE("","ICDFDA") K ICDFDA
  1. Q
  1. ;
  1. ;
  1. PROCUP1 ;
  1. ;;4795
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP2 ;
  1. ;;424
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP3 ; updating/replacing associated DRGs (;;Px code^old DRG^new DRG^DRG Grouper Effective date^associated MDC)
  1. ;;80.05^480^463^3071001^1
  1. ;;80.05^481^464^3071001^1
  1. ;;80.05^482^465^3071001^1
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP4 ; add associated DRGs (;;Px code^DRG^DRG Grouper Effective date^associated MDC)
  1. ;;81.05^456^3071001^8
  1. ;;81.05^457^3071001^8
  1. ;;81.05^458^3071001^8
  1. ;;81.05^459^3071001^8
  1. ;;81.05^460^3071001^8
  1. ;;EXIT
  1. ;
  1. ;
  1. PROCUP5 ;
  1. ;;9962
  1. ;;EXIT