- 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