- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1855L 2389 printed Mar 13, 2025@20:53:37 Page 2
- ICD1855L ;ALB/JDG - UPDATE DX & PX CODES;7/27/05 14:50; ; 10/5/11 3:23pm
- +1 ;;18.0;DRG Grouper;**55**;Oct 20,2000;Build 20
- +2 ;
- +3 QUIT
- +4 ;
- +5 ;DX - update DX identifier(s)
- ICDDX ;Update Dx
- +1 DO BMES^XPDUTL(">>> UPDATING DX CODE 730.28 IDENTIFIER...")
- +2 NEW LINE,X,ICDDXDA,DA,DIE,IDENT,DR
- +3 FOR LINE=1:1
- SET X=$TEXT(PROC+LINE)
- SET ICDDXDA=$PIECE(X,";;",2)
- if ICDDXDA="EXIT"
- QUIT
- Begin DoDot:1
- +4 SET DA=ICDDXDA
- +5 SET DIE="^ICD9("
- +6 SET IDENT="@"
- +7 SET DR="2///^S X=IDENT"
- +8 DO ^DIE
- +9 QUIT
- End DoDot:1
- +10 QUIT
- +11 ;
- +12 ;
- +13 ;PX - update PX identifier(s)
- ICDPX ;Update Px
- +1 DO BMES^XPDUTL(">>> UPDATING PX CODES 84.10 - 84.17...")
- +2 NEW LINE,X,ICDPXDA,DA,IDENT
- +3 SET DIE="^ICD0("
- SET DR="2///^S X=IDENT"
- +4 FOR LINE=1:1
- SET X=$TEXT(PROC1+LINE)
- SET ICDPXDA=$PIECE(X,";;",2)
- if ICDPXDA="EXIT"
- QUIT
- Begin DoDot:1
- +5 SET DA=ICDPXDA
- +6 SET IDENT="OA"
- +7 DO ^DIE
- +8 QUIT
- End DoDot:1
- +9 DO BMES^XPDUTL(">>> UPDATING PX CODE 64.0...")
- +10 NEW LINE,X,ICDPXDA1,DA,IDENT
- +11 FOR LINE=1:1
- SET X=$TEXT(PROC2+LINE)
- SET ICDPXDA1=$PIECE(X,";;",2)
- if ICDPXDA1="EXIT"
- QUIT
- Begin DoDot:1
- +12 SET DA=ICDPXDA1
- +13 SET IDENT="Oza"
- +14 DO ^DIE
- +15 QUIT
- End DoDot:1
- +16 DO BMES^XPDUTL(">>> UPDATING PX CODES 51.21 & 51.24...")
- +17 NEW LINE,X,ICDPXDA2,DA,IDENT
- +18 FOR LINE=1:1
- SET X=$TEXT(PROC3+LINE)
- SET ICDPXDA2=$PIECE(X,";;",2)
- if ICDPXDA2="EXIT"
- QUIT
- Begin DoDot:1
- +19 SET DA=ICDPXDA2
- +20 SET IDENT="OT"
- +21 DO ^DIE
- +22 QUIT
- End DoDot:1
- +23 DO BMES^XPDUTL(">>> UPDATING PX CODE 07.83 IDENTIFIER...")
- +24 NEW LINE,X,ICDPXDA3,DA,IDENT
- +25 FOR LINE=1:1
- SET X=$TEXT(PROC4+LINE)
- SET ICDPXDA3=$PIECE(X,";;",2)
- if ICDPXDA3="EXIT"
- QUIT
- Begin DoDot:1
- +26 SET DA=ICDPXDA3
- +27 SET IDENT="O"
- +28 DO ^DIE
- +29 QUIT
- End DoDot:1
- +30 DO BMES^XPDUTL(">>> UPDATING PX CODE 04.41...")
- +31 NEW ICDPXIEN,ICDDRGIEN,ICDDRGNUM,ICDDATE1,MDC1,DRGIEN
- +32 SET ICDDATE1=3071001
- SET MDC1=1
- +33 SET ICDPXIEN=$ORDER(^ICD0("AB","04.41",""))
- +34 SET ICDDRGIEN=$ORDER(^ICD0(ICDPXIEN,2,"B",ICDDATE1,""))
- +35 FOR ICDDRGNUM=31,32,33
- SET DRGIEN=$ORDER(^ICD0(ICDPXIEN,2,ICDDRGIEN,1,MDC1,1,"B",ICDDRGNUM,""))
- Begin DoDot:1
- +36 SET ICDFDA(80.17111,DRGIEN_","_MDC1_","_ICDDRGIEN_","_ICDPXIEN_",",.01)="@"
- End DoDot:1
- +37 DO UPDATE^DIE("","ICDFDA")
- KILL ICDFDA
- +38 QUIT
- +39 ;
- +40 ;
- +41 ;PX - update PX Major O.R. procedure
- ICDPX1 ; Update Px
- +1 DO BMES^XPDUTL(">>> UPDATING PX CODE 07.83 MAJOR O.R. PROCEDURE...")
- +2 NEW LINE,X,ICDPXDA3,DA,MAJOR
- +3 SET DIE="^ICD0("
- SET DR="20///^S X=MAJOR"
- +4 FOR LINE=1:1
- SET X=$TEXT(PROC4+LINE)
- SET ICDPXDA3=$PIECE(X,";;",2)
- if ICDPXDA3="EXIT"
- QUIT
- Begin DoDot:1
- +5 SET DA=ICDPXDA3
- +6 SET MAJOR="23"
- +7 DO ^DIE
- +8 QUIT
- End DoDot:1
- +9 ;
- +10 ;
- PROC ;
- +1 ;;4795
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROC1 ;
- +1 ;;3360
- +2 ;;2117
- +3 ;;2118
- +4 ;;2119
- +5 ;;2120
- +6 ;;2121
- +7 ;;2122
- +8 ;;2123
- +9 ;;EXIT
- +10 ;
- +11 ;
- PROC2 ;
- +1 ;;3308
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROC3 ;
- +1 ;;1017
- +2 ;;4108
- +3 ;;EXIT
- +4 ;
- +5 ;
- PROC4 ;
- +1 ;;4365
- +2 ;;EXIT
