ICD1827G ;;BAY/JAT - FY 2007 UPDATE;
;;18.0;DRG Grouper;**27**;Oct 13,2000;Build 2
;
D PRO
D CC
D DEL
D KIL
D DRG
D ACCEPT
Q
PRO ; update procedures with new identifier
N LINE,X,ICDPROC,ENTRY,IDENT,DA,DIE,DR,DUPE
F LINE=1:1 S X=$T(PROID+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
.S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0)) I ENTRY D
..; check for any dupe (there are some in MNTVBB)
..S DUPE=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I DUPE Q
..S IDENT=$P($G(^ICD0(ENTRY,0)),U,2)
..;check if already done in case being reinstalled
..I IDENT[$P(ICDPROC,U,2) Q
..S IDENT=IDENT_$P(ICDPROC,U,2)
..I $P(ICDPROC,U)="51.21" S IDENT="O"
..I $P(ICDPROC,U)="51.24" S IDENT="O"
..S DA=ENTRY,DIE="^ICD0("
..S DR="2///^S X=IDENT"
..D ^DIE
Q
PROID ;
;;53.61^z
;;78.60^z
;;78.61^z
;;78.63^z
;;78.64^z
;;78.65^z
;;78.68^z
;;39.52^7
;;51.21^999999
;;51.24^999999
;;EXIT
CC ; update complications/comorbidities field in diag file
N LINE,X,ICDDIAG,ENTRY,IDENT,DA,DIE,DR,DUPE
F LINE=1:1 S X=$T(CCID+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT" D
.S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0)) I ENTRY D
..; check for any dupe (there are some in MNTVBB)
..S DUPE=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",ENTRY)) I DUPE Q
..S IDENT=1
..S DA=ENTRY,DIE="^ICD9("
..S DR="70///^S X=IDENT"
..D ^DIE
Q
CCID ;
;;707.00^
;;707.01^
;;707.02^
;;707.04^
;;707.05^
;;707.06^
;;707.09^
;;EXIT
DEL ; delete DRG 496 in procedure file
N LINE,X,ICDPROC,ENTRY,ICIENS,FDA
F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
.S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
.I ENTRY D
..;check for possible inactive dupe
..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
..; check if already done in case patch being re-installed
..Q:'$D(^ICD0(ENTRY,2,1,1,2,1,"B",496,1))
..S ICIENS=1,ICIENS(1)=2,ICIENS(2)=1,ICIENS(3)=ENTRY
..S ICIENS=$$IENS^DILF(.ICIENS)
..S FDA(80.17111,ICIENS,.01)="@"
..D FILE^DIE("","FDA") K FDA
; delete DRG 223 in procedure file
S ENTRY=+$O(^ICD0("BA",78.13_" ",0))
I ENTRY D
.;check for possible inactive dupe
.I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",78.13_" ",ENTRY)) I 'ENTRY Q
.; check if already done in case patch being re-installed
.Q:'$D(^ICD0(ENTRY,2,1,1,1,1,"B",223,1))
.S ICIENS=1,ICIENS(1)=1,ICIENS(2)=1,ICIENS(3)=ENTRY
.S ICIENS=$$IENS^DILF(.ICIENS)
.S FDA(80.17111,ICIENS,.01)="@"
.D FILE^DIE("","FDA") K FDA
Q
REV ;
;;81.02^
;;81.03^
;;81.32^
;;81.33^
;;EXIT
KIL ; delete DRG 315 in diagnosis file
N LINE,X,ICDDIAG,ENTRY,ICIENS,FDA
F LINE=1:1 S X=$T(LIS+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT" D
.S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0))
.I ENTRY D
..;check for possible inactive dupe
..I $P($G(^ICD9(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",ENTRY)) I 'ENTRY Q
..; check if already done in case patch being re-installed
..Q:'$D(^ICD9(ENTRY,3,1,1,"B",315,1))
..S ICIENS=1,ICIENS(1)=1,ICIENS(2)=ENTRY
..S ICIENS=$$IENS^DILF(.ICIENS)
..S FDA(80.711,ICIENS,.01)="@"
..D FILE^DIE("","FDA") K FDA
Q
LIS ;
;;585.1^
;;585.2^
;;585.3^
;;585.4^
;;585.5^
;;585.6^
;;585.9^
;;EXIT
DRG ; update DRG in diag file
N ENTRY,ICIENS,FDA
S ENTRY=+$O(^ICD9("BA","724.8 ",0))
I ENTRY D
.; check if already done in case patch being re-installed
.Q:$D(^ICD9(ENTRY,3,1,1,"B",243,1))
.S ICIENS=1,ICIENS(1)=1,ICIENS(2)=ENTRY
.S ICIENS=$$IENS^DILF(.ICIENS)
.S FDA(80.711,ICIENS,.01)=243
.D FILE^DIE("","FDA") K FDA
S ENTRY=+$O(^ICD9("BA","053.19 ",0))
I ENTRY D
.; check if already done in case patch being re-installed
.Q:$D(^ICD9(ENTRY,3,1,1,"B",18,1))
.S ICIENS=1,ICIENS(1)=1,ICIENS(2)=ENTRY
.S ICIENS=$$IENS^DILF(.ICIENS)
.S FDA(80.711,ICIENS,.01)=18
.D FILE^DIE("","FDA") K FDA
Q
ACCEPT ; remove unacceptable as prime dx flag
N LINE,X,ICDDIAG,ENTRY,IDENT,DUPE,FDA
F LINE=1:1 S X=$T(ACPT+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT" D
.S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0)) I ENTRY D
..; check for any dupe (there are some in MNTVBB)
..S DUPE=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",ENTRY)) I DUPE Q
..S IDENT=$P($G(^ICD9(ENTRY,0)),U,4)
..S FDA(80,ENTRY_",",101)="@"
..D FILE^DIE("","FDA") K FDA
Q
ACPT ;
;;590.81^
;;595.4^
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1827G 4387 printed Apr 09, 2024@20:54:06 Page 2
ICD1827G ;;BAY/JAT - FY 2007 UPDATE;
+1 ;;18.0;DRG Grouper;**27**;Oct 13,2000;Build 2
+2 ;
+3 DO PRO
+4 DO CC
+5 DO DEL
+6 DO KIL
+7 DO DRG
+8 DO ACCEPT
+9 QUIT
PRO ; update procedures with new identifier
+1 NEW LINE,X,ICDPROC,ENTRY,IDENT,DA,DIE,DR,DUPE
+2 FOR LINE=1:1
SET X=$TEXT(PROID+LINE)
SET ICDPROC=$PIECE(X,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+3 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
IF ENTRY
Begin DoDot:2
+4 ; check for any dupe (there are some in MNTVBB)
+5 SET DUPE=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
IF DUPE
QUIT
+6 SET IDENT=$PIECE($GET(^ICD0(ENTRY,0)),U,2)
+7 ;check if already done in case being reinstalled
+8 IF IDENT[$PIECE(ICDPROC,U,2)
QUIT
+9 SET IDENT=IDENT_$PIECE(ICDPROC,U,2)
+10 IF $PIECE(ICDPROC,U)="51.21"
SET IDENT="O"
+11 IF $PIECE(ICDPROC,U)="51.24"
SET IDENT="O"
+12 SET DA=ENTRY
SET DIE="^ICD0("
+13 SET DR="2///^S X=IDENT"
+14 DO ^DIE
End DoDot:2
End DoDot:1
+15 QUIT
PROID ;
+1 ;;53.61^z
+2 ;;78.60^z
+3 ;;78.61^z
+4 ;;78.63^z
+5 ;;78.64^z
+6 ;;78.65^z
+7 ;;78.68^z
+8 ;;39.52^7
+9 ;;51.21^999999
+10 ;;51.24^999999
+11 ;;EXIT
CC ; update complications/comorbidities field in diag file
+1 NEW LINE,X,ICDDIAG,ENTRY,IDENT,DA,DIE,DR,DUPE
+2 FOR LINE=1:1
SET X=$TEXT(CCID+LINE)
SET ICDDIAG=$PIECE(X,";;",2)
if ICDDIAG="EXIT"
QUIT
Begin DoDot:1
+3 SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))
IF ENTRY
Begin DoDot:2
+4 ; check for any dupe (there are some in MNTVBB)
+5 SET DUPE=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))
IF DUPE
QUIT
+6 SET IDENT=1
+7 SET DA=ENTRY
SET DIE="^ICD9("
+8 SET DR="70///^S X=IDENT"
+9 DO ^DIE
End DoDot:2
End DoDot:1
+10 QUIT
CCID ;
+1 ;;707.00^
+2 ;;707.01^
+3 ;;707.02^
+4 ;;707.04^
+5 ;;707.05^
+6 ;;707.06^
+7 ;;707.09^
+8 ;;EXIT
DEL ; delete DRG 496 in procedure file
+1 NEW LINE,X,ICDPROC,ENTRY,ICIENS,FDA
+2 FOR LINE=1:1
SET X=$TEXT(REV+LINE)
SET ICDPROC=$PIECE(X,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+3 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
+4 IF ENTRY
Begin DoDot:2
+5 ;check for possible inactive dupe
+6 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+7 ; check if already done in case patch being re-installed
+8 if '$DATA(^ICD0(ENTRY,2,1,1,2,1,"B",496,1))
QUIT
+9 SET ICIENS=1
SET ICIENS(1)=2
SET ICIENS(2)=1
SET ICIENS(3)=ENTRY
+10 SET ICIENS=$$IENS^DILF(.ICIENS)
+11 SET FDA(80.17111,ICIENS,.01)="@"
+12 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+13 ; delete DRG 223 in procedure file
+14 SET ENTRY=+$ORDER(^ICD0("BA",78.13_" ",0))
+15 IF ENTRY
Begin DoDot:1
+16 ;check for possible inactive dupe
+17 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD0("BA",78.13_" ",ENTRY))
IF 'ENTRY
QUIT
+18 ; check if already done in case patch being re-installed
+19 if '$DATA(^ICD0(ENTRY,2,1,1,1,1,"B",223,1))
QUIT
+20 SET ICIENS=1
SET ICIENS(1)=1
SET ICIENS(2)=1
SET ICIENS(3)=ENTRY
+21 SET ICIENS=$$IENS^DILF(.ICIENS)
+22 SET FDA(80.17111,ICIENS,.01)="@"
+23 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:1
+24 QUIT
REV ;
+1 ;;81.02^
+2 ;;81.03^
+3 ;;81.32^
+4 ;;81.33^
+5 ;;EXIT
KIL ; delete DRG 315 in diagnosis file
+1 NEW LINE,X,ICDDIAG,ENTRY,ICIENS,FDA
+2 FOR LINE=1:1
SET X=$TEXT(LIS+LINE)
SET ICDDIAG=$PIECE(X,";;",2)
if ICDDIAG="EXIT"
QUIT
Begin DoDot:1
+3 SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))
+4 IF ENTRY
Begin DoDot:2
+5 ;check for possible inactive dupe
+6 IF $PIECE($GET(^ICD9(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+7 ; check if already done in case patch being re-installed
+8 if '$DATA(^ICD9(ENTRY,3,1,1,"B",315,1))
QUIT
+9 SET ICIENS=1
SET ICIENS(1)=1
SET ICIENS(2)=ENTRY
+10 SET ICIENS=$$IENS^DILF(.ICIENS)
+11 SET FDA(80.711,ICIENS,.01)="@"
+12 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+13 QUIT
LIS ;
+1 ;;585.1^
+2 ;;585.2^
+3 ;;585.3^
+4 ;;585.4^
+5 ;;585.5^
+6 ;;585.6^
+7 ;;585.9^
+8 ;;EXIT
DRG ; update DRG in diag file
+1 NEW ENTRY,ICIENS,FDA
+2 SET ENTRY=+$ORDER(^ICD9("BA","724.8 ",0))
+3 IF ENTRY
Begin DoDot:1
+4 ; check if already done in case patch being re-installed
+5 if $DATA(^ICD9(ENTRY,3,1,1,"B",243,1))
QUIT
+6 SET ICIENS=1
SET ICIENS(1)=1
SET ICIENS(2)=ENTRY
+7 SET ICIENS=$$IENS^DILF(.ICIENS)
+8 SET FDA(80.711,ICIENS,.01)=243
+9 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:1
+10 SET ENTRY=+$ORDER(^ICD9("BA","053.19 ",0))
+11 IF ENTRY
Begin DoDot:1
+12 ; check if already done in case patch being re-installed
+13 if $DATA(^ICD9(ENTRY,3,1,1,"B",18,1))
QUIT
+14 SET ICIENS=1
SET ICIENS(1)=1
SET ICIENS(2)=ENTRY
+15 SET ICIENS=$$IENS^DILF(.ICIENS)
+16 SET FDA(80.711,ICIENS,.01)=18
+17 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:1
+18 QUIT
ACCEPT ; remove unacceptable as prime dx flag
+1 NEW LINE,X,ICDDIAG,ENTRY,IDENT,DUPE,FDA
+2 FOR LINE=1:1
SET X=$TEXT(ACPT+LINE)
SET ICDDIAG=$PIECE(X,";;",2)
if ICDDIAG="EXIT"
QUIT
Begin DoDot:1
+3 SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))
IF ENTRY
Begin DoDot:2
+4 ; check for any dupe (there are some in MNTVBB)
+5 SET DUPE=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))
IF DUPE
QUIT
+6 SET IDENT=$PIECE($GET(^ICD9(ENTRY,0)),U,4)
+7 SET FDA(80,ENTRY_",",101)="@"
+8 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+9 QUIT
ACPT ;
+1 ;;590.81^
+2 ;;595.4^
+3 ;;EXIT
