Routine: DVB460P

DVB460P ;ALB/TCK POST-INSTALL FOR PATCH DVB*4*60 ; 2/21/2008

 ;;4.0;HINQ;**60**;03/25/92;Build 6

PS ; post-install entry point

 ; create KIDS checkpoints with call backs

 N FBX

 F FBX="ICD" D

 . S Y=$$NEWCP^XPDUTL(FBX,FBX_"^DVB460P")

 . I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

ICD ;

 ; Map the ICD diagnosis code, 295.90 to disability condition 9204

 D BMES^XPDUTL("  Mapping diagnosis code 295.90 to Disability condition, 9204.")

 ;Locate the IEN of file (#80) that contains the 295.90 diagnosis code

 N PTR,ICD,RD

 S PTR="",ICD=295.90,RD=9204

 I '$D(^ICD9("BA")) D  Q

 .D BMES^XPDUTL("Error mapping diagnosis code "_ICD_" to rated disability "_RD_".  Cross reference is missing.")

 S PTR=$O(^ICD9("BA",ICD,PTR))

 I PTR'>0 D  Q

 .D BMES^XPDUTL("Error. Diagnosis code "_ICD_" is missing from ICD Diagnosis file, #80.  Mapping was not successful.")

 D MAP(PTR,RD,ICD)

MAP(PTR,RD,ICD) ;

 N RDARY,RPTR,DD,DO,DA,DIE,DR,X,Y

 S (RDARY,RPTR)=""

 I '$D(^DIC(31,"C")) D  Q

 .D BMES^XPDUTL("Error mapping diagnosis code "_ICD_" to rated disability "_RD_".  Cross reference is missing.")

 F  S RPTR=$O(^DIC(31,"C",RD,RPTR)) Q:RPTR=""  D

 .Q:RPTR'>0

 .S RDARY(RD,RPTR)=""

 I '$D(RDARY) D  Q

 .D BMES^XPDUTL(" Error. Rated Disability "_RD_" is missing from Disability Condition file, #31.")

 F  S RPTR=$O(RDARY(RD,RPTR)) Q:RPTR=""  D

 .Q:RPTR=""

 .I $D(^DIC(31,RPTR,"ICD","B",PTR)) D  Q

 ..D BMES^XPDUTL(" Diagnosis code "_ICD_" is already mapped to Rated disability "_RD_".")

 .S DA(1)=RPTR

 .S DA=$O(^DIC(31,DA(1),"ICD","B",PTR,0))

 .I DA'>0 D  Q:DA'>0

 ..S DIC="^DIC(31,"_DA(1)_",""ICD"",",DIC(0)="L",DIC("P")="31.01PA",DLAYGO=31.01

 ..S X=PTR

 ..K DD,DO D FILE^DICN

 ..K DIC,DLAYGO

 ..S DA=+Y

.;

 .S DIE="^DIC(31,"_DA(1)_",""ICD"","

 .S DR=".02///0"

 .D ^DIE

 ;DVB460P

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVB460P   1857     printed  Mar 13, 2025@21:02:24                                                                                                                                                                                                     Page 2

DVB460P   ;ALB/TCK POST-INSTALL FOR PATCH DVB*4*60 ; 2/21/2008

 +1       ;;4.0;HINQ;**60**;03/25/92;Build 6

 +2        QUIT

 +3       ;

PS        ; post-install entry point

 +1       ; create KIDS checkpoints with call backs

 +2        NEW FBX

 +3        FOR FBX="ICD"

               Begin DoDot:1

 +4                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^DVB460P")

 +5                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +6        QUIT

 +7       ;

ICD       ;

 +1       ; Map the ICD diagnosis code, 295.90 to disability condition 9204

 +2        DO BMES^XPDUTL("  Mapping diagnosis code 295.90 to Disability condition, 9204.")

 +3       ;Locate the IEN of file (#80) that contains the 295.90 diagnosis code

 +4        NEW PTR,ICD,RD

 +5        SET PTR=""

           SET ICD=295.90

           SET RD=9204

 +6        IF '$DATA(^ICD9("BA"))

               Begin DoDot:1

 +7                DO BMES^XPDUTL("Error mapping diagnosis code "_ICD_" to rated disability "_RD_".  Cross reference is missing.")

               End DoDot:1

               QUIT

 +8        SET PTR=$ORDER(^ICD9("BA",ICD,PTR))

 +9        IF PTR'>0

               Begin DoDot:1

 +10               DO BMES^XPDUTL("Error. Diagnosis code "_ICD_" is missing from ICD Diagnosis file, #80.  Mapping was not successful.")

               End DoDot:1

               QUIT

 +11       DO MAP(PTR,RD,ICD)

 +12       QUIT

 +13      ;

MAP(PTR,RD,ICD) ;

 +1        NEW RDARY,RPTR,DD,DO,DA,DIE,DR,X,Y

 +2        SET (RDARY,RPTR)=""

 +3        IF '$DATA(^DIC(31,"C"))

               Begin DoDot:1

 +4                DO BMES^XPDUTL("Error mapping diagnosis code "_ICD_" to rated disability "_RD_".  Cross reference is missing.")

               End DoDot:1

               QUIT

 +5        FOR

               SET RPTR=$ORDER(^DIC(31,"C",RD,RPTR))

               if RPTR=""

                   QUIT

               Begin DoDot:1

 +6                if RPTR'>0

                       QUIT

 +7                SET RDARY(RD,RPTR)=""

               End DoDot:1

 +8        IF '$DATA(RDARY)

               Begin DoDot:1

 +9                DO BMES^XPDUTL(" Error. Rated Disability "_RD_" is missing from Disability Condition file, #31.")

               End DoDot:1

               QUIT

 +10       FOR

               SET RPTR=$ORDER(RDARY(RD,RPTR))

               if RPTR=""

                   QUIT

               Begin DoDot:1

 +11               if RPTR=""

                       QUIT

 +12               IF $DATA(^DIC(31,RPTR,"ICD","B",PTR))

                       Begin DoDot:2

 +13                       DO BMES^XPDUTL(" Diagnosis code "_ICD_" is already mapped to Rated disability "_RD_".")

                       End DoDot:2

                       QUIT

 +14               SET DA(1)=RPTR

 +15               SET DA=$ORDER(^DIC(31,DA(1),"ICD","B",PTR,0))

 +16               IF DA'>0

                       Begin DoDot:2

 +17                       SET DIC="^DIC(31,"_DA(1)_",""ICD"","

                           SET DIC(0)="L"

                           SET DIC("P")="31.01PA"

                           SET DLAYGO=31.01

 +18                       SET X=PTR

 +19                       KILL DD,DO

                           DO FILE^DICN

 +20                       KILL DIC,DLAYGO

 +21                       SET DA=+Y

                       End DoDot:2

                       if DA'>0

                           QUIT

 +22      ;

 +23               SET DIE="^DIC(31,"_DA(1)_",""ICD"","

 +24               SET DR=".02///0"

 +25               DO ^DIE

               End DoDot:1

 +26       QUIT

 +27      ;

 +28      ;DVB460P

DVB460P.m