DVB460P ;ALB/TCK POST-INSTALL FOR PATCH DVB*4*60 ; 2/21/2008
;;4.0;HINQ;**60**;03/25/92;Build 6
Q
;
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.")
Q
;
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)
Q
;
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
Q
;
;DVB460P
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVB460P 1857 printed Nov 22, 2024@17:07:55 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
