ICD1862L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
;;18.0;DRG Grouper;**62**;Oct 20,2000;Build 7
;
Q
;
; Update Dx code(s)
ICDUPDDX ; update DX identifier(s)
D BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
N LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
F LINE=1:1 S LINEXX=$T(PROCUP1+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
.S DA=ICDDXDA
.S DIE="^ICD9("
.S IDENT="k"
.S DR="2///^S X=IDENT"
.D ^DIE
;
;
;DX - update DX MDC24 field
D BMES^XPDUTL(">>> UPDATING DX CODE 860.0...")
N LINE,LINEXX,ICDDXDA,DA,DIE,NMDC24C,DR
F LINE=1:1 S LINEXX=$T(PROCUP5+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
.S DA=ICDDXDA
.S DIE="^ICD9("
.S NMDC24C=2
.S DR="5.7///^S X=NMDC24C"
.D ^DIE
Q
;
;
; Update Px code(s)
ICDUPDPX ; Update Px identifier(s)
D BMES^XPDUTL(">>> UPDATING PX CODE 31.1 MAJOR O.R. PROCEDURE...")
N LINE,LINEXX,ICDPXDA3,DA,MAJOR
S DIE="^ICD0(",DR="20///^S X=MAJOR"
F LINE=1:1 S LINEXX=$T(PROCUP2+LINE) S ICDPXDA3=$P(LINEXX,";;",2) Q:ICDPXDA3="EXIT" D
.S DA=ICDPXDA3
.S MAJOR="9"
.D ^DIE
;
; updating/replacing associated DRGs
D BMES^XPDUTL(">>> UPDATING PX CODE 80.05 DRGs...")
N ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDTXTTP
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
.S ICDPXIENX=ICDTXTFP_" " ;DEBUG
.S ICDDRGREP=ICDTXTTP
.S ICDPXIEN=$O(^ICD0("AB",ICDPXIENX,""))
.I +ICDPXIEN D ;DEBUG
..S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
..S ICDDRGNUM=ICDTXTSP S DRGIEN=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
..S ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGREP
..D UPDATE^DIE("","ICDFDA") K ICDFDA
;
; add associated DRGs
D BMES^XPDUTL(">>> UPDATING PX CODE 81.05 DRGs...")
N ICDPXIEN,ICDDRGIEN,ICDDATE1,MDC1,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDMDCLVL,ICDPXIENX,ICDDRGADD
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
.S ICDMDCLVL=0
.S ICDPXIENX=ICDTXTFP_" " ;DEBUG
.S ICDDRGADD=ICDTXTSP
.S ICDPXIEN=$O(^ICD0("AB",ICDPXIENX,""))
.S ICDDRGIEN=$O(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
.F S ICDMDCLVL=$O(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL)) Q:(ICDMDCLVL="")!($G(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL,0))=MDC1)
.S ICDFDA(80.17111,"+1,"_ICDMDCLVL_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGADD
.D UPDATE^DIE("","ICDFDA") K ICDFDA
Q
;
;
PROCUP1 ;
;;4795
;;EXIT
;
;
PROCUP2 ;
;;424
;;EXIT
;
;
PROCUP3 ; updating/replacing associated DRGs (;;Px code^old DRG^new DRG^DRG Grouper Effective date^associated MDC)
;;80.05^480^463^3071001^1
;;80.05^481^464^3071001^1
;;80.05^482^465^3071001^1
;;EXIT
;
;
PROCUP4 ; add associated DRGs (;;Px code^DRG^DRG Grouper Effective date^associated MDC)
;;81.05^456^3071001^8
;;81.05^457^3071001^8
;;81.05^458^3071001^8
;;81.05^459^3071001^8
;;81.05^460^3071001^8
;;EXIT
;
;
PROCUP5 ;
;;9962
;;EXIT
ICD1862L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
+1 ;;18.0;DRG Grouper;**62**;Oct 20,2000;Build 7
+2 ;
+3 QUIT
+4 ;
+5 ; Update Dx code(s)
ICDUPDDX ; update DX identifier(s)
+1 DO BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
+2 NEW LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
+3 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP1+LINE)
SET ICDDXDA=$PIECE(LINEXX,";;",2)
IF ICDDXDA="EXIT"
QUIT
Begin DoDot:1
+4 SET DA=ICDDXDA
+5 SET DIE="^ICD9("
+6 SET IDENT="k"
+7 SET DR="2///^S X=IDENT"
+8 DO ^DIE
End DoDot:1
+9 ;
+10 ;
+11 ;DX - update DX MDC24 field
+12 DO BMES^XPDUTL(">>> UPDATING DX CODE 860.0...")
+13 NEW LINE,LINEXX,ICDDXDA,DA,DIE,NMDC24C,DR
+14 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP5+LINE)
SET ICDDXDA=$PIECE(LINEXX,";;",2)
IF ICDDXDA="EXIT"
QUIT
Begin DoDot:1
+15 SET DA=ICDDXDA
+16 SET DIE="^ICD9("
+17 SET NMDC24C=2
+18 SET DR="5.7///^S X=NMDC24C"
+19 DO ^DIE
End DoDot:1
+20 QUIT
+21 ;
+22 ;
+23 ; Update Px code(s)
ICDUPDPX ; Update Px identifier(s)
+1 DO BMES^XPDUTL(">>> UPDATING PX CODE 31.1 MAJOR O.R. PROCEDURE...")
+2 NEW LINE,LINEXX,ICDPXDA3,DA,MAJOR
+3 SET DIE="^ICD0("
SET DR="20///^S X=MAJOR"
+4 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP2+LINE)
SET ICDPXDA3=$PIECE(LINEXX,";;",2)
IF ICDPXDA3="EXIT"
QUIT
Begin DoDot:1
+5 SET DA=ICDPXDA3
+6 SET MAJOR="9"
+7 DO ^DIE
End DoDot:1
+8 ;
+9 ; updating/replacing associated DRGs
+10 DO BMES^XPDUTL(">>> UPDATING PX CODE 80.05 DRGs...")
+11 NEW ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDTXTTP
+12 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP3+LINE)
SET ICDTXT=$PIECE(LINEXX,";;",2)
SET ICDTXTFP=$PIECE(ICDTXT,"^")
SET ICDTXTSP=$PIECE(ICDTXT,"^",2)
SET ICDTXTTP=$PIECE(ICDTXT,"^",3)
SET ICDDATE1=$PIECE(ICDTXT,"^",4)
SET MDC1=$PIECE(ICDTXT,"^",5)
IF ICDTXT="EXIT"
QUIT
Begin DoDot:1
+13 ;DEBUG
SET ICDPXIENX=ICDTXTFP_" "
+14 SET ICDDRGREP=ICDTXTTP
+15 SET ICDPXIEN=$ORDER(^ICD0("AB",ICDPXIENX,""))
+16 ;DEBUG
IF +ICDPXIEN
Begin DoDot:2
+17 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
+18 SET ICDDRGNUM=ICDTXTSP
SET DRGIEN=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
+19 SET ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGREP
+20 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:2
End DoDot:1
+21 ;
+22 ; add associated DRGs
+23 DO BMES^XPDUTL(">>> UPDATING PX CODE 81.05 DRGs...")
+24 NEW ICDPXIEN,ICDDRGIEN,ICDDATE1,MDC1,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDMDCLVL,ICDPXIENX,ICDDRGADD
+25 FOR LINE=1:1
SET LINEXX=$TEXT(PROCUP4+LINE)
SET ICDTXT=$PIECE(LINEXX,";;",2)
SET ICDTXTFP=$PIECE(ICDTXT,"^")
SET ICDTXTSP=$PIECE(ICDTXT,"^",2)
SET ICDDATE1=$PIECE(ICDTXT,"^",3)
SET MDC1=$PIECE(ICDTXT,"^",4)
IF ICDTXT="EXIT"
QUIT
Begin DoDot:1
+26 SET ICDMDCLVL=0
+27 ;DEBUG
SET ICDPXIENX=ICDTXTFP_" "
+28 SET ICDDRGADD=ICDTXTSP
+29 SET ICDPXIEN=$ORDER(^ICD0("AB",ICDPXIENX,""))
+30 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
+31 FOR
SET ICDMDCLVL=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL))
IF (ICDMDCLVL="")!($GET(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL,0))=MDC1)
QUIT
+32 SET ICDFDA(80.17111,"+1,"_ICDMDCLVL_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGADD
+33 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+34 QUIT
+35 ;
+36 ;
PROCUP1 ;
+1 ;;4795
+2 ;;EXIT
+3 ;
+4 ;
PROCUP2 ;
+1 ;;424
+2 ;;EXIT
+3 ;
+4 ;
PROCUP3 ; updating/replacing associated DRGs (;;Px code^old DRG^new DRG^DRG Grouper Effective date^associated MDC)
+1 ;;80.05^480^463^3071001^1
+2 ;;80.05^481^464^3071001^1
+3 ;;80.05^482^465^3071001^1
+4 ;;EXIT
+5 ;
+6 ;
PROCUP4 ; add associated DRGs (;;Px code^DRG^DRG Grouper Effective date^associated MDC)
+1 ;;81.05^456^3071001^8
+2 ;;81.05^457^3071001^8
+3 ;;81.05^458^3071001^8
+4 ;;81.05^459^3071001^8
+5 ;;81.05^460^3071001^8
+6 ;;EXIT
+7 ;
+8 ;
PROCUP5 ;
+1 ;;9962
+2 ;;EXIT
