- ICD1869L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
- ;;18.0;DRG Grouper;**69**;Oct 20,2000;Build 4
- ;
- Q
- ;
- ; Update Dx code(s)
- ICDUPDDX ; update DX identifier(s)
- D BMES^XPDUTL(">>> UPDATING DX CODE 482.42 IDENTIFIER...")
- N LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
- S DIE="^ICD9(",DR="2///^S X=IDENT"
- F LINE=1:1 S LINEXX=$T(PROCUP1+LINE) S ICDDXDA=$P(LINEXX,";;",2) Q:ICDDXDA="EXIT" D
- .S DA=ICDDXDA
- .S IDENT="k"
- .D ^DIE
- .Q
- D BMES^XPDUTL(">>> UPDATING DX CODE 779.84 IDENTIFIER...")
- N LINE,DXTXT,ICDDXDA1,DA,IDENT
- F LINE=1:1 S DXTXT=$T(PROCUP3+LINE) S ICDDXDA1=$P(DXTXT,";;",2) Q:ICDDXDA1="EXIT" D
- .S DA=ICDDXDA1
- .S IDENT="S"
- .D ^DIE
- .Q
- D BMES^XPDUTL(">>> UPDATING DX CODE V64.06 IDENTIFIER...")
- N LINE,DXTXT,ICDDXDA4,DA,IDENT
- F LINE=1:1 S DXTXT=$T(PROCUP4+LINE) S ICDDXDA4=$P(DXTXT,";;",2) Q:ICDDXDA4="EXIT" D
- .S DA=ICDDXDA4
- .S IDENT="S"
- .D ^DIE
- .Q
- D BMES^XPDUTL(">>> UPDATING DX CODE V18.0 IDENTIFIER...")
- N LINE,DXTXT,ICDDXDA2,DA,IDENT
- F LINE=1:1 S DXTXT=$T(PROCUP5+LINE) S ICDDXDA2=$P(DXTXT,";;",2) Q:ICDDXDA2="EXIT" D
- .S DA=ICDDXDA2
- .S IDENT="S"
- .D ^DIE
- .Q
- Q
- ;
- ;
- ; Update Px code(s)
- ICDUPDPX ; Update Px identifier(s)
- D BMES^XPDUTL(">>> UPDATING PX CODE 32.20 IDENTIFIER...")
- N LINE,LINEXX,ICDPXDA3,DA,IDENT,DR,DIE
- F LINE=1:1 S LINEXX=$T(PROCUP2+LINE) S ICDPXDA3=$P(LINEXX,";;",2) Q:ICDPXDA3="EXIT" D
- .S DIE="^ICD0(",DR="2///^S X=IDENT"
- .S DA=ICDPXDA3
- .S IDENT="O"
- .D ^DIE
- Q
- ;
- ;
- ICDECUP1 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.20
- N ICDSAVXC,ICDXC,ICDDX
- S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
- S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
- S $P(^DD(45.89,.01,0),U,2)=ICDXC
- F ICDDX=294.20 D
- .S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
- .Q:+Y'>0
- .I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
- ..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
- .S DIC="^DIC(45.89,",DIC(0)=""
- .S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
- .K DO D FILE^DICN
- .I +Y<0 D Q
- ..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
- .D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
- S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
- K DIC,DIE,DA,DR,Y,X
- Q
- ;
- ;
- ICDECUP2 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.21
- N ICDSAVXC,ICDXC,ICDDX
- S ICDSAVXC=$P(^DD(45.89,.01,0),U,2) ;diagnosis/procedure code field
- S ICDXC=$P(ICDSAVXC,"I",1)_$P(ICDSAVXC,"I",2,99) ;Remove the 'I'
- S $P(^DD(45.89,.01,0),U,2)=ICDXC
- F ICDDX=294.21 D
- .S DIC="^ICD9(",DIC(0)="MX",X=ICDDX D ^DIC
- .Q:+Y'>0
- .I $D(^DIC(45.89,"ASPL",+Y_";ICD9(")) D Q
- ..D MES^XPDUTL(">>>>Entry "_$P(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
- .S DIC="^DIC(45.89,",DIC(0)=""
- .S DIC("DR")=".01///5"_";.02///"_ICDDX,X="PSYCHIATRY AXIS CLASSIFICATION"
- .K DO D FILE^DICN
- .I +Y<0 D Q
- ..D MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
- .D MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
- S $P(^DD(45.89,.01,0),U,2)=ICDSAVXC
- K DIC,DIE,DA,DR,Y,X
- Q
- ;
- ;
- PROCUP1 ;
- ;;14734
- ;;EXIT
- ;
- ;
- PROCUP2 ;
- ;;4369
- ;;EXIT
- ;
- ;
- PROCUP3 ;
- ;;14156
- ;;EXIT
- ;
- ;
- PROCUP4 ;
- ;;14211
- ;;EXIT
- ;
- ;
- PROCUP5 ;
- ;;11396
- ;;EXIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1869L 3414 printed Feb 18, 2025@23:15:29 Page 2
- ICD1869L ;ALB/JDG - UPDATE DX & PX CODES ; 10/5/11 3:23pm
- +1 ;;18.0;DRG Grouper;**69**;Oct 20,2000;Build 4
- +2 ;
- +3 QUIT
- +4 ;
- +5 ; Update Dx code(s)
- ICDUPDDX ; update DX identifier(s)
- +1 DO BMES^XPDUTL(">>> UPDATING DX CODE 482.42 IDENTIFIER...")
- +2 NEW LINE,LINEXX,ICDDXDA,DA,DIE,IDENT,DR
- +3 SET DIE="^ICD9("
- SET DR="2///^S X=IDENT"
- +4 FOR LINE=1:1
- SET LINEXX=$TEXT(PROCUP1+LINE)
- SET ICDDXDA=$PIECE(LINEXX,";;",2)
- if ICDDXDA="EXIT"
- QUIT
- Begin DoDot:1
- +5 SET DA=ICDDXDA
- +6 SET IDENT="k"
- +7 DO ^DIE
- +8 QUIT
- End DoDot:1
- +9 DO BMES^XPDUTL(">>> UPDATING DX CODE 779.84 IDENTIFIER...")
- +10 NEW LINE,DXTXT,ICDDXDA1,DA,IDENT
- +11 FOR LINE=1:1
- SET DXTXT=$TEXT(PROCUP3+LINE)
- SET ICDDXDA1=$PIECE(DXTXT,";;",2)
- if ICDDXDA1="EXIT"
- QUIT
- Begin DoDot:1
- +12 SET DA=ICDDXDA1
- +13 SET IDENT="S"
- +14 DO ^DIE
- +15 QUIT
- End DoDot:1
- +16 DO BMES^XPDUTL(">>> UPDATING DX CODE V64.06 IDENTIFIER...")
- +17 NEW LINE,DXTXT,ICDDXDA4,DA,IDENT
- +18 FOR LINE=1:1
- SET DXTXT=$TEXT(PROCUP4+LINE)
- SET ICDDXDA4=$PIECE(DXTXT,";;",2)
- if ICDDXDA4="EXIT"
- QUIT
- Begin DoDot:1
- +19 SET DA=ICDDXDA4
- +20 SET IDENT="S"
- +21 DO ^DIE
- +22 QUIT
- End DoDot:1
- +23 DO BMES^XPDUTL(">>> UPDATING DX CODE V18.0 IDENTIFIER...")
- +24 NEW LINE,DXTXT,ICDDXDA2,DA,IDENT
- +25 FOR LINE=1:1
- SET DXTXT=$TEXT(PROCUP5+LINE)
- SET ICDDXDA2=$PIECE(DXTXT,";;",2)
- if ICDDXDA2="EXIT"
- QUIT
- Begin DoDot:1
- +26 SET DA=ICDDXDA2
- +27 SET IDENT="S"
- +28 DO ^DIE
- +29 QUIT
- End DoDot:1
- +30 QUIT
- +31 ;
- +32 ;
- +33 ; Update Px code(s)
- ICDUPDPX ; Update Px identifier(s)
- +1 DO BMES^XPDUTL(">>> UPDATING PX CODE 32.20 IDENTIFIER...")
- +2 NEW LINE,LINEXX,ICDPXDA3,DA,IDENT,DR,DIE
- +3 FOR LINE=1:1
- SET LINEXX=$TEXT(PROCUP2+LINE)
- SET ICDPXDA3=$PIECE(LINEXX,";;",2)
- if ICDPXDA3="EXIT"
- QUIT
- Begin DoDot:1
- +4 SET DIE="^ICD0("
- SET DR="2///^S X=IDENT"
- +5 SET DA=ICDPXDA3
- +6 SET IDENT="O"
- +7 DO ^DIE
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;
- ICDECUP1 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.20
- +1 NEW ICDSAVXC,ICDXC,ICDDX
- +2 ;diagnosis/procedure code field
- SET ICDSAVXC=$PIECE(^DD(45.89,.01,0),U,2)
- +3 ;Remove the 'I'
- SET ICDXC=$PIECE(ICDSAVXC,"I",1)_$PIECE(ICDSAVXC,"I",2,99)
- +4 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDXC
- +5 FOR ICDDX=294.20
- Begin DoDot:1
- +6 SET DIC="^ICD9("
- SET DIC(0)="MX"
- SET X=ICDDX
- DO ^DIC
- +7 if +Y'>0
- QUIT
- +8 IF $DATA(^DIC(45.89,"ASPL",+Y_";ICD9("))
- Begin DoDot:2
- +9 DO MES^XPDUTL(">>>>Entry "_$PIECE(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:2
- QUIT
- +10 SET DIC="^DIC(45.89,"
- SET DIC(0)=""
- +11 SET DIC("DR")=".01///5"_";.02///"_ICDDX
- SET X="PSYCHIATRY AXIS CLASSIFICATION"
- +12 KILL DO
- DO FILE^DICN
- +13 IF +Y<0
- Begin DoDot:2
- +14 DO MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:2
- QUIT
- +15 DO MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:1
- +16 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDSAVXC
- +17 KILL DIC,DIE,DA,DR,Y,X
- +18 QUIT
- +19 ;
- +20 ;
- ICDECUP2 ; Update PTF EXPANDED CODE (#45.89) file w/ Dx code 294.21
- +1 NEW ICDSAVXC,ICDXC,ICDDX
- +2 ;diagnosis/procedure code field
- SET ICDSAVXC=$PIECE(^DD(45.89,.01,0),U,2)
- +3 ;Remove the 'I'
- SET ICDXC=$PIECE(ICDSAVXC,"I",1)_$PIECE(ICDSAVXC,"I",2,99)
- +4 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDXC
- +5 FOR ICDDX=294.21
- Begin DoDot:1
- +6 SET DIC="^ICD9("
- SET DIC(0)="MX"
- SET X=ICDDX
- DO ^DIC
- +7 if +Y'>0
- QUIT
- +8 IF $DATA(^DIC(45.89,"ASPL",+Y_";ICD9("))
- Begin DoDot:2
- +9 DO MES^XPDUTL(">>>>Entry "_$PIECE(Y,U,2)_" already exists in the PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:2
- QUIT
- +10 SET DIC="^DIC(45.89,"
- SET DIC(0)=""
- +11 SET DIC("DR")=".01///5"_";.02///"_ICDDX
- SET X="PSYCHIATRY AXIS CLASSIFICATION"
- +12 KILL DO
- DO FILE^DICN
- +13 IF +Y<0
- Begin DoDot:2
- +14 DO MES^XPDUTL(">>>>Entry already exists, nothing added to the PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:2
- QUIT
- +15 DO MES^XPDUTL(">>>>Entry added to PTF EXPANDED CODE (#45.89) file. ")
- End DoDot:1
- +16 SET $PIECE(^DD(45.89,.01,0),U,2)=ICDSAVXC
- +17 KILL DIC,DIE,DA,DR,Y,X
- +18 QUIT
- +19 ;
- +20 ;
- PROCUP1 ;
- +1 ;;14734
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROCUP2 ;
- +1 ;;4369
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROCUP3 ;
- +1 ;;14156
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROCUP4 ;
- +1 ;;14211
- +2 ;;EXIT
- +3 ;
- +4 ;
- PROCUP5 ;
- +1 ;;11396
- +2 ;;EXIT