- ICD1848Y ;ALB/EG/MJB - PX UPDATES;6/24/05 3:29pm
- ;;18.0;DRG Grouper;**48**;Oct 13,2000;Build 7
- ;
- ; 2 line tags are in this routine. See ICD18XXP to find which tag
- ;is being called. Not all are used for each patch.
- ;These tags are for any needed corrections to DRG Groupings.
- ;PRO - is for making changes to the procedure code, add drg effective
- ;date,etc (fields will be in REV linetag)
- ;ID is to add or update an identifier for a procedure code(fields
- ; will be in REVID)
- Q
- ;
- PRO ;
- D BMES^XPDUTL(">>>Modifying procedure codes - file 80.1")
- D MES^XPDUTL(">>>for new DRGs")
- N LINE,ICDX,ICDPROC,ENTRY,SUBLINE,DATA,FDA
- F LINE=1:1 S ICDX=$T(REV+LINE) S ICDPROC=$P(ICDX,";;",2) Q:ICDPROC="EXIT" D
- .Q:ICDPROC["+"
- .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 created in case patch being re-installed
- ..Q:$D(^ICD0(ENTRY,2,"B",3081001))
- ..;add 80.171, 80.1711 and 80.17111 records
- ..F SUBLINE=1:1 S ICDX=$T(REV+LINE+SUBLINE) S DATA=$P(ICDX,";;",2) Q:DATA'["+" D
- ...I SUBLINE=1 D
- ....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- ....S FDA(1820,80.171,"+2,?1,",.01)=3081001
- ....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
- ...S DATA=$E(DATA,2,99)
- ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- ...S FDA(1820,80.171,"?2,?1,",.01)=3081001
- ...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
- ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
- ...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- ...S FDA(1820,80.171,"?2,?1,",.01)=3081001
- ...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
- ...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
- ...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
- ...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
- ...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
- ...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
- ...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
- ...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
- Q
- ID ;modify Identifier field (#2) in file 80.1
- N LINE,ICDX,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
- F LINE=1:1 S ICDX=$T(REVID+LINE) S ICDPROC=$P(ICDX,";;",2) Q:ICDPROC="EXIT" D
- .S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
- .; check if already done in case patch is being re-installed
- .S IDENT=$P($G(^ICD0(ENTRY,0)),U,2)
- .S IDENA=$P(ICDPROC,U,2)
- .I IDENT[IDENA D ICDMSG Q
- .S IDENT=IDENT_IDENA D
- .S DA=ENTRY,DIE="^ICD0("
- .S DR="2///^S X=IDENT"
- .D ^DIE
- Q
- ;
- ICDMSG ;
- D BMES^XPDUTL(">>> IDENTIFIER ALREADY UPDATED - NO CHANGE HAS BEEN MADE ")
- D MES^XPDUTL(" TO PROCEDURE CODE: "_ICDPROC) Q
- REV ;changes to procedure, if any
- ;;EXIT
- ;;
- REVID ; PX code,Identifier - additions, changes or deletions, if any of PX identifiers.
- ;;81.05^OF
- ;;81.63^OF
- ;;57.93^Of
- ;;EXIT
- ICD1848Y ;ALB/EG/MJB - PX UPDATES;6/24/05 3:29pm
- +1 ;;18.0;DRG Grouper;**48**;Oct 13,2000;Build 7
- +2 ;
- +3 ; 2 line tags are in this routine. See ICD18XXP to find which tag
- +4 ;is being called. Not all are used for each patch.
- +5 ;These tags are for any needed corrections to DRG Groupings.
- +6 ;PRO - is for making changes to the procedure code, add drg effective
- +7 ;date,etc (fields will be in REV linetag)
- +8 ;ID is to add or update an identifier for a procedure code(fields
- +9 ; will be in REVID)
- +10 QUIT
- +11 ;
- PRO ;
- +1 DO BMES^XPDUTL(">>>Modifying procedure codes - file 80.1")
- +2 DO MES^XPDUTL(">>>for new DRGs")
- +3 NEW LINE,ICDX,ICDPROC,ENTRY,SUBLINE,DATA,FDA
- +4 FOR LINE=1:1
- SET ICDX=$TEXT(REV+LINE)
- SET ICDPROC=$PIECE(ICDX,";;",2)
- IF ICDPROC="EXIT"
- QUIT
- Begin DoDot:1
- +5 IF ICDPROC["+"
- QUIT
- +6 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
- +7 IF ENTRY
- Begin DoDot:2
- +8 ;check for possible inactive dupe
- +9 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
- SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
- IF 'ENTRY
- QUIT
- +10 ; check if already created in case patch being re-installed
- +11 IF $DATA(^ICD0(ENTRY,2,"B",3081001))
- QUIT
- +12 ;add 80.171, 80.1711 and 80.17111 records
- +13 FOR SUBLINE=1:1
- SET ICDX=$TEXT(REV+LINE+SUBLINE)
- SET DATA=$PIECE(ICDX,";;",2)
- IF DATA'["+"
- QUIT
- Begin DoDot:3
- +14 IF SUBLINE=1
- Begin DoDot:4
- +15 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +16 SET FDA(1820,80.171,"+2,?1,",.01)=3081001
- +17 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:4
- +18 SET DATA=$EXTRACT(DATA,2,99)
- +19 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +20 SET FDA(1820,80.171,"?2,?1,",.01)=3081001
- +21 SET FDA(1820,80.1711,"+3,?2,?1,",.01)=$PIECE(DATA,U)
- +22 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- +23 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
- +24 SET FDA(1820,80.171,"?2,?1,",.01)=3081001
- +25 SET FDA(1820,80.1711,"?3,?2,?1,",.01)=$PIECE(DATA,U)
- +26 SET FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(DATA,U,2)
- +27 IF $PIECE(DATA,U,3)
- SET FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(DATA,U,3)
- +28 IF $PIECE(DATA,U,4)
- SET FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(DATA,U,4)
- +29 IF $PIECE(DATA,U,5)
- SET FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(DATA,U,5)
- +30 IF $PIECE(DATA,U,6)
- SET FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(DATA,U,6)
- +31 IF $PIECE(DATA,U,7)
- SET FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(DATA,U,7)
- +32 DO UPDATE^DIE("","FDA(1820)")
- KILL FDA(1820)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +33 QUIT
- ID ;modify Identifier field (#2) in file 80.1
- +1 NEW LINE,ICDX,ICDPROC,ENTRY,DA,DIE,DR,IDENT,DIC
- +2 FOR LINE=1:1
- SET ICDX=$TEXT(REVID+LINE)
- SET ICDPROC=$PIECE(ICDX,";;",2)
- IF ICDPROC="EXIT"
- QUIT
- Begin DoDot:1
- +3 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
- +4 ; check if already done in case patch is being re-installed
- +5 SET IDENT=$PIECE($GET(^ICD0(ENTRY,0)),U,2)
- +6 SET IDENA=$PIECE(ICDPROC,U,2)
- +7 IF IDENT[IDENA
- DO ICDMSG
- QUIT
- +8 SET IDENT=IDENT_IDENA
- Begin DoDot:2
- End DoDot:2
- +9 SET DA=ENTRY
- SET DIE="^ICD0("
- +10 SET DR="2///^S X=IDENT"
- +11 DO ^DIE
- End DoDot:1
- +12 QUIT
- +13 ;
- ICDMSG ;
- +1 DO BMES^XPDUTL(">>> IDENTIFIER ALREADY UPDATED - NO CHANGE HAS BEEN MADE ")
- +2 DO MES^XPDUTL(" TO PROCEDURE CODE: "_ICDPROC)
- QUIT
- REV ;changes to procedure, if any
- +1 ;;EXIT
- +2 ;;
- REVID ; PX code,Identifier - additions, changes or deletions, if any of PX identifiers.
- +1 ;;81.05^OF
- +2 ;;81.63^OF
- +3 ;;57.93^Of
- +4 ;;EXIT
