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

ICD1855L.m

Go to the documentation of this file.
ICD1855L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; ; 10/5/11 3:23pm
 ;;18.0;DRG Grouper;**55**;Oct 20,2000;Build 20
 ;
 Q
 ;
 ;DX - update DX identifier(s)
ICDDX ;Update Dx
 D BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
 N LINE,X,ICDDXDA,DA,DIE,IDENT,DR
 F LINE=1:1 S X=$T(PROC+LINE) S ICDDXDA=$P(X,";;",2) Q:ICDDXDA="EXIT"  D
 .S DA=ICDDXDA
 .S DIE="^ICD9("
 .S IDENT="@"
 .S DR="2///^S X=IDENT"
 .D ^DIE
 .Q
 Q
 ;
 ;
 ;PX - update PX identifier(s)
ICDPX ;Update Px
 D BMES^XPDUTL(">>> UPDATING PX CODES 84.10 - 84.17...")
 N LINE,X,ICDPXDA,DA,IDENT
 S DIE="^ICD0(",DR="2///^S X=IDENT"
 F LINE=1:1 S X=$T(PROC1+LINE) S ICDPXDA=$P(X,";;",2) Q:ICDPXDA="EXIT"  D
 .S DA=ICDPXDA
 .S IDENT="OA"
 .D ^DIE
 .Q
 D BMES^XPDUTL(">>> UPDATING PX CODE 64.0...")
 N LINE,X,ICDPXDA1,DA,IDENT
 F LINE=1:1 S X=$T(PROC2+LINE) S ICDPXDA1=$P(X,";;",2) Q:ICDPXDA1="EXIT"  D
 .S DA=ICDPXDA1
 .S IDENT="Oza"
 .D ^DIE
 .Q
 D BMES^XPDUTL(">>> UPDATING PX CODES 51.21 & 51.24...")
 N LINE,X,ICDPXDA2,DA,IDENT
 F LINE=1:1 S X=$T(PROC3+LINE) S ICDPXDA2=$P(X,";;",2) Q:ICDPXDA2="EXIT"  D
 .S DA=ICDPXDA2
 .S IDENT="OT"
 .D ^DIE
 .Q
 D BMES^XPDUTL(">>> UPDATING PX CODE 07.83 IDENTIFIER...")
 N LINE,X,ICDPXDA3,DA,IDENT
 F LINE=1:1 S X=$T(PROC4+LINE) S ICDPXDA3=$P(X,";;",2) Q:ICDPXDA3="EXIT"  D
 .S DA=ICDPXDA3
 .S IDENT="O"
 .D ^DIE
 .Q
 D BMES^XPDUTL(">>> UPDATING PX CODE 04.41...")
 N ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN
 S ICDDATE1=3071001,MDC1=1
 S ICDPXIEN=$O(^ICD0("AB","04.41",""))
 S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
 F ICDDRGNUM=31,32,33 S DRGIEN=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))  D
 .S ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)="@"
 D UPDATE^DIE("","ICDFDA") K ICDFDA
 Q
 ;
 ;
 ;PX - update PX Major O.R. procedure
ICDPX1 ; Update Px
 D BMES^XPDUTL(">>> UPDATING PX CODE 07.83 MAJOR O.R. PROCEDURE...")
 N LINE,X,ICDPXDA3,DA,MAJOR
 S DIE="^ICD0(",DR="20///^S X=MAJOR"
 F LINE=1:1 S X=$T(PROC4+LINE) S ICDPXDA3=$P(X,";;",2) Q:ICDPXDA3="EXIT"  D
 .S DA=ICDPXDA3
 .S MAJOR="23"
 .D ^DIE
 .Q
 ;
 ; 
PROC ;
 ;;4795
 ;;EXIT
 ;
 ;
PROC1 ;
 ;;3360
 ;;2117
 ;;2118
 ;;2119
 ;;2120
 ;;2121
 ;;2122
 ;;2123
 ;;EXIT
 ;
 ;
PROC2 ;
 ;;3308
 ;;EXIT
 ;
 ;
PROC3 ;
 ;;1017
 ;;4108
 ;;EXIT
 ;
 ;
PROC4 ;
 ;;4365
 ;;EXIT