- 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 Feb 18, 2025@23:14:37 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
