ICD1862L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
;;18.0;DRG Grouper;**62**;Oct 20,2000;Build 10
;
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
.S ICDDRGREP=ICDTXTTP
.S ICDPXIEN=$O(^ICD0("AB",ICDPXIENX,""))
.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
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1862L 3199 printed Sep 02, 2024@18:34:18 Page 2
ICD1862L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
+1 ;;18.0;DRG Grouper;**62**;Oct 20,2000;Build 10
+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 SET ICDPXIENX=ICDTXTFP
+14 SET ICDDRGREP=ICDTXTTP
+15 SET ICDPXIEN=$ORDER(^ICD0("AB",ICDPXIENX,""))
+16 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
+17 SET ICDDRGNUM=ICDTXTSP
SET DRGIEN=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
+18 SET ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGREP
+19 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+20 ;
+21 ; add associated DRGs
+22 DO BMES^XPDUTL(">>> UPDATING PX CODE 81.05 DRGs...")
+23 NEW ICDPXIEN,ICDDRGIEN,ICDDATE1,MDC1,LINE,LINEXX,ICDTXT,ICDTXTFP,ICDTXTSP,ICDMDCLVL,ICDPXIENX,ICDDRGADD
+24 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
+25 SET ICDMDCLVL=0
+26 SET ICDPXIENX=ICDTXTFP
+27 SET ICDDRGADD=ICDTXTSP
+28 SET ICDPXIEN=$ORDER(^ICD0("AB",ICDPXIENX,""))
+29 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
+30 FOR
SET ICDMDCLVL=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL))
if (ICDMDCLVL="")!($GET(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,ICDMDCLVL,0))=MDC1)
QUIT
+31 SET ICDFDA(80.17111,"+1,"_ICDMDCLVL_","_ICDDRGIEN_","_ICDPXIEN_",",.01)=ICDDRGADD
+32 DO UPDATE^DIE("","ICDFDA")
KILL ICDFDA
End DoDot:1
+33 QUIT
+34 ;
+35 ;
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
