Routine: BCSVP2

BCSVP2 ;IHS/MSC/BWF - CSV Patch 1 ;3-Mar-2010 19:05;BF

 ;;1.0;BCSV;**2**;APR 23,2010

 ;=================================================================

 ;  BCSV patch 2 post install

PRE ;

 I '$D(^XPD(9.6,"B","BCSV*1.0*1")) S XPDABORT=1

 I $G(XPDABORT) D BMES^XPDUTL("BCSV*1.0*1 must be installed to continue!") Q

POST ;

 N ICDCODE,SIEN,AGELOW,AGEHIGH,ICD90,OALOW,OAHIGH,ICDCODE

 S REPONLY=$G(REPONLY)

 I $G(REPONLY) D DISPHDR

 ; grab old age ranges and put them back into the ICD file.

 S X=0 F  S X=$O(^ICD9(X)) Q:'X  D

 .S ICDCODE=$P(^ICD9(X,0),U,1)_" "

 .; get source ien

 .S SIEN=$O(^XCSVICD9("BA",ICDCODE,0)) Q:'SIEN

 .S IHSIEN=$O(^ICD9("BA",ICDCODE,0)) Q:'IHSIEN

 .S AGELOW=$$AGELOW(SIEN,IHSIEN),AGEHIGH=$$AGEHIGH(SIEN,IHSIEN)

 .S ICD90=$G(^ICD9(IHSIEN,0)),OALOW=$P(ICD90,U,14),OAHIGH=$P(ICD90,U,15)

 .I OALOW="",AGELOW="",OAHIGH="",AGEHIGH="" Q

 .I OALOW=AGELOW,OAHIGH=AGEHIGH Q

 .I REPONLY D DISP(ICDCODE,AGELOW,AGEHIGH,OALOW,OAHIGH) Q

 .S FDA(80,X_",",14)=AGELOW

 .S FDA(80,X_",",15)=AGEHIGH

 .D FILE^DIE(,"FDA","ERR")

 D FIXICM

 D ICDUPD

FIXICM ; kill off entries that were added in the wrong place

 N QUIT,LINE,KIEN,NIEN

 S QUIT=0

 F I=1:1 D  Q:QUIT

 .S LINE=$P($T(DAT+I),";;",2) I LINE=" Q"!(LINE']"") S QUIT=1 Q

 .K KIEN,NIEN

 .S KIEN=$P(LINE,":"),NIEN(1)=$P(LINE,":",2)

 .S DIK="^ICM(",DA=KIEN D ^DIK

 .; if an entry already exists here, do not file it again

 .I '$D(^ICM(NIEN(1))) D

 ..K FDA S FDA(80.3,"+1,",.01)=$P($G(^XCSV("ICM","DATA",NIEN(1),0)),U,1)

 ..D UPDATE^DIE(,"FDA","NIEN","BCSVERR") K FDA

 .; add data back into entry

 .M ^ICM(NIEN(1))=^XCSV("ICM","DATA",NIEN(1))

 .; reindex

 S DIK="^ICM(" D IXALL^DIK

ICDUPD ;

 N DRG,BCSVDT,BCSVSIEN,BCSVDESC

 S DRG=0 F  S DRG=$O(^ICD(DRG)) Q:'DRG  D

 .S BCSVDT=$O(^ICD(DRG,68,"B",9999999),-1) Q:'BCSVDT

 .S BCSVSIEN=$O(^ICD(DRG,68,"B",BCSVDT,0)) Q:'BCSVSIEN

 .S BCSVDESC=$$GET1^DIQ(80.2681,"1,"_BCSVSIEN_","_DRG_",",.01,"E")

 .S FDA(80.21,"1,"_DRG_",",.01)=BCSVDESC

 .D FILE^DIE(,"FDA") K FDA

AGELOW(IEN,IHSIEN) ;

 N ALOW

 Q:'IEN

 ; first check to see if there is a value in piece 14

 S ALOW=$P(^XCSVICD9(IEN,0),U,14)

 I 'ALOW S ALOW=$P($G(^ICD9(IHSIEN,9999999)),U)

 Q ALOW

AGEHIGH(IEN,IHSIEN) ;

 N AHIGH

 Q:'IEN

 S AHIGH=$P(^XCSVICD9(IEN,0),U,15)

 I 'AHIGH S AHIGH=$P($G(^ICD9(IHSIEN,9999999)),U,2)

 Q AHIGH

DISP(CODE,NALOW,NAHIGH,OALOW,OAHIGH) ;

 W !,CODE,?20,OALOW,?35,NALOW,?50,OAHIGH,?65,NAHIGH

DISPHDR ;

 W @IOF

 W !,"ICD CODE",?20,"CSV AGE LOW",?35,"IHS AGE LOW",?50,"CSV AGE HIGH",?65,"IHS AGE HIGH"

 W !,"--------",?20,"-----------",?35,"-----------",?50,"------------",?65,"------------"

DAT ;

 ;;100:26

 ;;101:27

 ;;102:28

 ;;103:98

BCSVP2    ;IHS/MSC/BWF - CSV Patch 1 ;3-Mar-2010 19:05;BF

 +1       ;;1.0;BCSV;**2**;APR 23,2010

 +2       ;=================================================================

 +3       ;  BCSV patch 2 post install

PRE       ;

 +1        IF '$DATA(^XPD(9.6,"B","BCSV*1.0*1"))

               SET XPDABORT=1

 +2        IF $GET(XPDABORT)

               DO BMES^XPDUTL("BCSV*1.0*1 must be installed to continue!")

               QUIT

 +3        QUIT

POST      ;

 +1        NEW ICDCODE,SIEN,AGELOW,AGEHIGH,ICD90,OALOW,OAHIGH,ICDCODE

 +2        SET REPONLY=$GET(REPONLY)

 +3        IF $GET(REPONLY)

               DO DISPHDR

 +4       ; grab old age ranges and put them back into the ICD file.

 +5        SET X=0

FOR

               SET X=$ORDER(^ICD9(X))

               IF 'X

                   QUIT

               Begin DoDot:1

 +6                SET ICDCODE=$PIECE(^ICD9(X,0),U,1)_" "

 +7       ; get source ien

 +8                SET SIEN=$ORDER(^XCSVICD9("BA",ICDCODE,0))

                   IF 'SIEN

                       QUIT

 +9                SET IHSIEN=$ORDER(^ICD9("BA",ICDCODE,0))

                   IF 'IHSIEN

                       QUIT

 +10               SET AGELOW=$$AGELOW(SIEN,IHSIEN)

                   SET AGEHIGH=$$AGEHIGH(SIEN,IHSIEN)

 +11               SET ICD90=$GET(^ICD9(IHSIEN,0))

                   SET OALOW=$PIECE(ICD90,U,14)

                   SET OAHIGH=$PIECE(ICD90,U,15)

 +12               IF OALOW=""

                       IF AGELOW=""

                           IF OAHIGH=""

                               IF AGEHIGH=""

                                   QUIT

 +13               IF OALOW=AGELOW

                       IF OAHIGH=AGEHIGH

                           QUIT

 +14               IF REPONLY

                       DO DISP(ICDCODE,AGELOW,AGEHIGH,OALOW,OAHIGH)

                       QUIT

 +15               SET FDA(80,X_",",14)=AGELOW

 +16               SET FDA(80,X_",",15)=AGEHIGH

 +17               DO FILE^DIE(,"FDA","ERR")

               End DoDot:1

 +18       DO FIXICM

 +19       DO ICDUPD

 +20       QUIT

FIXICM    ; kill off entries that were added in the wrong place

 +1        NEW QUIT,LINE,KIEN,NIEN

 +2        SET QUIT=0

 +3        FOR I=1:1

               Begin DoDot:1

 +4                SET LINE=$PIECE($TEXT(DAT+I),";;",2)

                   IF LINE=" Q"!(LINE']"")

                       SET QUIT=1

                       QUIT

 +5                KILL KIEN,NIEN

 +6                SET KIEN=$PIECE(LINE,":")

                   SET NIEN(1)=$PIECE(LINE,":",2)

 +7                SET DIK="^ICM("

                   SET DA=KIEN

                   DO ^DIK

 +8       ; if an entry already exists here, do not file it again

 +9                IF '$DATA(^ICM(NIEN(1)))

                       Begin DoDot:2

 +10                       KILL FDA

                           SET FDA(80.3,"+1,",.01)=$PIECE($GET(^XCSV("ICM","DATA",NIEN(1),0)),U,1)

 +11                       DO UPDATE^DIE(,"FDA","NIEN","BCSVERR")

                           KILL FDA

                       End DoDot:2

 +12      ; add data back into entry

 +13               MERGE ^ICM(NIEN(1))=^XCSV("ICM","DATA",NIEN(1))

 +14      ; reindex

               End DoDot:1

               IF QUIT

                   QUIT

 +15       SET DIK="^ICM("

           DO IXALL^DIK

 +16       QUIT

 +17      ;

ICDUPD    ;

 +1        NEW DRG,BCSVDT,BCSVSIEN,BCSVDESC

 +2        SET DRG=0

FOR

               SET DRG=$ORDER(^ICD(DRG))

               IF 'DRG

                   QUIT

               Begin DoDot:1

 +3                SET BCSVDT=$ORDER(^ICD(DRG,68,"B",9999999),-1)

                   IF 'BCSVDT

                       QUIT

 +4                SET BCSVSIEN=$ORDER(^ICD(DRG,68,"B",BCSVDT,0))

                   IF 'BCSVSIEN

                       QUIT

 +5                SET BCSVDESC=$$GET1^DIQ(80.2681,"1,"_BCSVSIEN_","_DRG_",",.01,"E")

 +6                SET FDA(80.21,"1,"_DRG_",",.01)=BCSVDESC

 +7                DO FILE^DIE(,"FDA")

                   KILL FDA

               End DoDot:1

 +8        QUIT

AGELOW(IEN,IHSIEN) ;

 +1        NEW ALOW

 +2        IF 'IEN

               QUIT

 +3       ; first check to see if there is a value in piece 14

 +4        SET ALOW=$PIECE(^XCSVICD9(IEN,0),U,14)

 +5        IF 'ALOW

               SET ALOW=$PIECE($GET(^ICD9(IHSIEN,9999999)),U)

 +6        QUIT ALOW

AGEHIGH(IEN,IHSIEN) ;

 +1        NEW AHIGH

 +2        IF 'IEN

               QUIT

 +3        SET AHIGH=$PIECE(^XCSVICD9(IEN,0),U,15)

 +4        IF 'AHIGH

               SET AHIGH=$PIECE($GET(^ICD9(IHSIEN,9999999)),U,2)

 +5        QUIT AHIGH

 +6       ;

DISP(CODE,NALOW,NAHIGH,OALOW,OAHIGH) ;

 +1        WRITE !,CODE,?20,OALOW,?35,NALOW,?50,OAHIGH,?65,NAHIGH

 +2        QUIT

DISPHDR   ;

 +1        WRITE @IOF

 +2        WRITE !,"ICD CODE",?20,"CSV AGE LOW",?35,"IHS AGE LOW",?50,"CSV AGE HIGH",?65,"IHS AGE HIGH"

 +3        WRITE !,"--------",?20,"-----------",?35,"-----------",?50,"------------",?65,"------------"

 +4        QUIT

DAT       ;

 +1       ;;100:26

 +2       ;;101:27

 +3       ;;102:28

 +4       ;;103:98

 +5        QUIT

BCSVP2.m