DVB445PT.m

DVB445PT ;ALB/ZJF - POST-INSTALL FOR PATCH DVB*4*45 ; 8/13/03

 ;;4.0;HINQ;**45**;03/25/92

 ;

 ;This routine will be run as a post-installation for patch DVB*4*45.

 ;This routine will add nine and change three disability codes in the DISABILITY

 ;CONDITION file (#31).

 ;

POST ;entry point for post-install, setting up checkpoints

 N %

 S %=$$NEWCP^XPDUTL("DVBLINE","EN^DVB445PT",1)

 Q

 ;

EN ;begin processing

 ;

 N DVBLINE

 ;

 D BMES^XPDUTL("  >> *** Updating DISABILITY CONDITION file (#31)")

 D MES^XPDUTL("  ")

 ;

 ;get value from checkpoints, previous run

 S DVBLINE=+$$PARCP^XPDUTL("DVBLINE")

 ;

DVBNEW ;add new codes or modify name if code is in use

 ;

 F DVBI=DVBLINE:1 S DVBJ=$P($T(NEWCODE+DVBI),";;",2) Q:DVBJ["$EXIT"  D

 .S DVBCODE=+DVBJ,DVBNAME=$E($P(DVBJ,"^",2),1,45),DVBLINE=DVBI

 .S DVBDESC=$E($P(DVBJ,"^",3),1,200)

 .;

 .;add new code

 .I '$D(^DIC(31,"C",DVBCODE)) D  G UPDATECH

 ..K DD,DO

 ..S DIC="^DIC(31,",DIC(0)="L",DIC("DR")="2////"_DVBCODE_";10////"_DVBDESC

 ..S X=DVBNAME,DLAYGO=31

 ..D FILE^DICN

 ..I $G(Y)'>0 D MES^XPDUTL("  >>>> error updating "_DVBCODE_" code ") Q

 ..D MES^XPDUTL(DVBCODE_":  adding  "_DVBCODE_"  "_X)

 ..K DLAYGO,DIC,X

 ..Q

 .;

 .;modify name

 .S DVBIEN=+$O(^DIC(31,"C",DVBCODE,0))

 .S DVBREC=$G(^DIC(31,DVBIEN,0)),DVBOLDSC=$G(^DIC(31,DVBIEN,1)) I DVBREC']"" D  G UPDATECH

 ..D MES^XPDUTL("  >>>> error "_DVBCODE_" in C x-reference and not in file 31")

 ..Q

 .S DVBOLDN=$P(DVBREC,"^") I DVBOLDN=DVBNAME&(DVBOLDSC=DVBDESC) G UPDATECH

 .S DA=DVBIEN,DIE="^DIC(31,",DR=".01////"_DVBNAME_";10////"_DVBDESC

 .D ^DIE

 .K DR,DA,DIE

 .I DVBOLDN'=DVBNAME D

 ..D MES^XPDUTL(DVBCODE_": changing name from "_DVBOLDN)

 ..D MES^XPDUTL("                    to   "_DVBNAME)

 .I DVBOLDSC'=DVBDESC D

 ..D MES^XPDUTL(DVBCODE_": changing description...")

 ..D MES^XPDUTL("          from:  "_DVBOLDSC)

 ..D MES^XPDUTL("            to:  "_DVBDESC)

 .;

UPDATECH .;update checkpoint

 .S %=$$UPCP^XPDUTL("DVBLINE",DVBLINE)

 .Q

 K DVBCODE,DVBI,DVBIEN,DVBJ,DVBNAME,DVBOLDN,DVBREC,DVBDESC,DVBOLDSC,Y

 Q

 ;

NEWCODE ;codes to be added or changed

 ;

 ;;7822^PAPULOSQUAMOUS DISORDERS^PAPULOSQUAMOUS DISORDERS

 ;;7823^VITILIGO^VITILIGO

 ;;7824^DISEASES OF KERATINIZATION^DISEASES OF KERATINIZATION

 ;;7826^VASCULITIS, PRIMARY CUTANEOUS^VASCULITIS, PRIMARY CUTANEOUS

 ;;7827^ERYTHEMA MULTIFORME, TOXIC EPIDERMAL NECROLYSIS^ERYTHEMA MULTIFORME, TOXIC EPIDERMAL NECROLYSIS

 ;;7830^SCARRING ALOPECIA^SCARRING ALOPECIA

 ;;7831^ALOPECIA AREATA^ALOPECIA AREATA

 ;;7832^HYPERHIDROSIS^HYPERHIDROSIS

 ;;7833^MALIGNANT MELANOMA^MALIGNANT MELANOMA

 ;;5256^LOSS OF MOTION OF KNEE^LOSS OF MOTION OF KNEE

 ;;5262^LOWER LEG CONDITION^LOWER LEG CONDITION

 ;;5284^RESIDUALS OF FOOT INJURY^RESIDUALS OF FOOT INJURY

 ;;$EXIT

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVB445PT   2797     printed  Mar 13, 2025@21:02:15                                                                                                                                                                                                    Page 2

DVB445PT  ;ALB/ZJF - POST-INSTALL FOR PATCH DVB*4*45 ; 8/13/03

 +1       ;;4.0;HINQ;**45**;03/25/92

 +2       ;

 +3       ;This routine will be run as a post-installation for patch DVB*4*45.

 +4       ;This routine will add nine and change three disability codes in the DISABILITY

 +5       ;CONDITION file (#31).

 +6       ;

POST      ;entry point for post-install, setting up checkpoints

 +1        NEW %

 +2        SET %=$$NEWCP^XPDUTL("DVBLINE","EN^DVB445PT",1)

 +3        QUIT 

 +4       ;

EN        ;begin processing

 +1       ;

 +2        NEW DVBLINE

 +3       ;

 +4        DO BMES^XPDUTL("  >> *** Updating DISABILITY CONDITION file (#31)")

 +5        DO MES^XPDUTL("  ")

 +6       ;

 +7       ;get value from checkpoints, previous run

 +8        SET DVBLINE=+$$PARCP^XPDUTL("DVBLINE")

 +9       ;

DVBNEW    ;add new codes or modify name if code is in use

 +1       ;

 +2        FOR DVBI=DVBLINE:1

               SET DVBJ=$PIECE($TEXT(NEWCODE+DVBI),";;",2)

               if DVBJ["$EXIT"

                   QUIT 

               Begin DoDot:1

 +3                SET DVBCODE=+DVBJ

                   SET DVBNAME=$EXTRACT($PIECE(DVBJ,"^",2),1,45)

                   SET DVBLINE=DVBI

 +4                SET DVBDESC=$EXTRACT($PIECE(DVBJ,"^",3),1,200)

 +5       ;

 +6       ;add new code

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

                       Begin DoDot:2

 +8                        KILL DD,DO

 +9                        SET DIC="^DIC(31,"

                           SET DIC(0)="L"

                           SET DIC("DR")="2////"_DVBCODE_";10////"_DVBDESC

 +10                       SET X=DVBNAME

                           SET DLAYGO=31

 +11                       DO FILE^DICN

 +12                       IF $GET(Y)'>0

                               DO MES^XPDUTL("  >>>> error updating "_DVBCODE_" code ")

                               QUIT 

 +13                       DO MES^XPDUTL(DVBCODE_":  adding  "_DVBCODE_"  "_X)

 +14                       KILL DLAYGO,DIC,X

 +15                       QUIT 

                       End DoDot:2

                       GOTO UPDATECH

 +16      ;

 +17      ;modify name

 +18               SET DVBIEN=+$ORDER(^DIC(31,"C",DVBCODE,0))

 +19               SET DVBREC=$GET(^DIC(31,DVBIEN,0))

                   SET DVBOLDSC=$GET(^DIC(31,DVBIEN,1))

                   IF DVBREC']""

                       Begin DoDot:2

 +20                       DO MES^XPDUTL("  >>>> error "_DVBCODE_" in C x-reference and not in file 31")

 +21                       QUIT 

                       End DoDot:2

                       GOTO UPDATECH

 +22               SET DVBOLDN=$PIECE(DVBREC,"^")

                   IF DVBOLDN=DVBNAME&(DVBOLDSC=DVBDESC)

                       GOTO UPDATECH

 +23               SET DA=DVBIEN

                   SET DIE="^DIC(31,"

                   SET DR=".01////"_DVBNAME_";10////"_DVBDESC

 +24               DO ^DIE

 +25               KILL DR,DA,DIE

 +26               IF DVBOLDN'=DVBNAME

                       Begin DoDot:2

 +27                       DO MES^XPDUTL(DVBCODE_": changing name from "_DVBOLDN)

 +28                       DO MES^XPDUTL("                    to   "_DVBNAME)

                       End DoDot:2

 +29               IF DVBOLDSC'=DVBDESC

                       Begin DoDot:2

 +30                       DO MES^XPDUTL(DVBCODE_": changing description...")

 +31                       DO MES^XPDUTL("          from:  "_DVBOLDSC)

 +32                       DO MES^XPDUTL("            to:  "_DVBDESC)

                       End DoDot:2

 +33      ;

UPDATECH  ;update checkpoint

 +1                SET %=$$UPCP^XPDUTL("DVBLINE",DVBLINE)

 +2                QUIT 

               End DoDot:1

 +3        KILL DVBCODE,DVBI,DVBIEN,DVBJ,DVBNAME,DVBOLDN,DVBREC,DVBDESC,DVBOLDSC,Y

 +4        QUIT 

 +5       ;

NEWCODE   ;codes to be added or changed

 +1       ;

 +2       ;;7822^PAPULOSQUAMOUS DISORDERS^PAPULOSQUAMOUS DISORDERS

 +3       ;;7823^VITILIGO^VITILIGO

 +4       ;;7824^DISEASES OF KERATINIZATION^DISEASES OF KERATINIZATION

 +5       ;;7826^VASCULITIS, PRIMARY CUTANEOUS^VASCULITIS, PRIMARY CUTANEOUS

 +6       ;;7827^ERYTHEMA MULTIFORME, TOXIC EPIDERMAL NECROLYSIS^ERYTHEMA MULTIFORME, TOXIC EPIDERMAL NECROLYSIS

 +7       ;;7830^SCARRING ALOPECIA^SCARRING ALOPECIA

 +8       ;;7831^ALOPECIA AREATA^ALOPECIA AREATA

 +9       ;;7832^HYPERHIDROSIS^HYPERHIDROSIS

 +10      ;;7833^MALIGNANT MELANOMA^MALIGNANT MELANOMA

 +11      ;;5256^LOSS OF MOTION OF KNEE^LOSS OF MOTION OF KNEE

 +12      ;;5262^LOWER LEG CONDITION^LOWER LEG CONDITION

 +13      ;;5284^RESIDUALS OF FOOT INJURY^RESIDUALS OF FOOT INJURY

 +14      ;;$EXIT

 +15       QUIT