DVBA2803.m

DVBA2803 ;SPH - PATCH DRIVER ; 11/17/05

 ;;2.7;AMIE;**103**;Apr 10, 1995

 ;

 ; Make sure to call each exam name being sent in the patch

 ; This routine will find existing matching entries and will ensure they're disabled.

 ; Call as a pre-init or else it'll disable the exams just loaded.

PRE ;

 N DVBVERSS,DVBVERSN

 S DVBVERSS="103F" ; What the version will be in the incoming file

 S DVBVERSN="103T1" ; What the final version should be named

 W !!!,"**** PRE-PROCESSING ****",!!

 D DISABLE("ACROMEGALY")

 D DISABLE("ARRHYTHMIAS")

 D DISABLE("ARTERIES, VEINS AND MISCELLANEOUS")

 D DISABLE("BRAIN AND SPINAL CORD")

 D DISABLE("COLD INJURY PROTOCOL EXAMINATION")

 D DISABLE("CRANIAL NERVES")

 D DISABLE("CUSHINGS SYNDROME")

 D DISABLE("DENTAL AND ORAL")

 D DISABLE("DIGESTIVE CONDITIONS, MISCELLANEOUS")

 D DISABLE("EATING DISORDERS")

 D DISABLE("EPILEPSY AND NARCOLEPSY")

 D DISABLE("ESOPHAGUS AND HIATAL HERNIA")

 D DISABLE("FIBROMYALGIA")

 D DISABLE("GULF WAR GUIDELINES")

 D DISABLE("GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST")

 D DISABLE("HIV-RELATED ILLNESS")

 D DISABLE("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")

 D DISABLE("INTESTINES (LARGE AND SMALL)")

 D DISABLE("LIVER, GALL BLADDER, AND PANCREAS")

 D DISABLE("LYMPHATIC DISORDERS")

 D DISABLE("MISCELLANEOUS ENDOCRINE DISEASES")

 D DISABLE("MOUTH, LIPS AND TONGUE")

 D DISABLE("PRISONER OF WAR PROTOCOL EXAMINATION")

 D DISABLE("PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES")

 D DISABLE("RECTUM AND ANUS")

 D DISABLE("RESIDUALS OF AMPUTATIONS")

 D DISABLE("SENSE OF SMELL AND TASTE")

 D DISABLE("SOCIAL WORK AND INDUSTRIAL SURVEY")

 D DISABLE("THYROID AND PARATHYROID DISEASES")

 Q

POST ;

 N DVBVERSS,DVBVERSN

 S DVBVERSS="103F" ; What the version will be in the incoming file

 S DVBVERSN="103T1" ; What the final version should be named

 W !!!,"**** POST-PROCESSING ****",!!

 D POSTP("ACROMEGALY")

 D POSTP("ARRHYTHMIAS")

 D POSTP("ARTERIES, VEINS AND MISCELLANEOUS")

 D POSTP("BRAIN AND SPINAL CORD")

 D POSTP("COLD INJURY PROTOCOL EXAMINATION")

 D POSTP("CRANIAL NERVES")

 D POSTP("CUSHINGS SYNDROME")

 D POSTP("DENTAL AND ORAL")

 D POSTP("DIGESTIVE CONDITIONS, MISCELLANEOUS")

 D POSTP("EATING DISORDERS")

 D POSTP("EPILEPSY AND NARCOLEPSY")

 D POSTP("ESOPHAGUS AND HIATAL HERNIA")

 D POSTP("FIBROMYALGIA")

 D POSTP("GULF WAR GUIDELINES")

 D POSTP("GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST")

 D POSTP("HIV-RELATED ILLNESS")

 D POSTP("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")

 D POSTP("INTESTINES (LARGE AND SMALL)")

 D POSTP("LIVER, GALL BLADDER, AND PANCREAS")

 D POSTP("LYMPHATIC DISORDERS")

 D POSTP("MISCELLANEOUS ENDOCRINE DISEASES")

 D POSTP("MOUTH, LIPS AND TONGUE")

 D POSTP("PRISONER OF WAR PROTOCOL EXAMINATION")

 D POSTP("PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES")

 D POSTP("RECTUM AND ANUS")

 D POSTP("RESIDUALS OF AMPUTATIONS")

 D POSTP("SENSE OF SMELL AND TASTE")

 D POSTP("SOCIAL WORK AND INDUSTRIAL SURVEY")

 D POSTP("THYROID AND PARATHYROID DISEASES")

 D RBXREF

 Q

POSTP(NM) ;

 ; Rename XXXXXXX~imported version to XXXXXXX~new version

 N DVBABCNT,DVBABIEN,DVBABST,DVBACH

 N DVBABCN2,DVBABIE2,DVBABS2

 S DVBABCNT=0,DVBABIEN=0

 F  S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN  D

 .S DVBABST=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)

 .I $P(DVBABST,"~",1)=NM  I $P(DVBABST,"~",2)=DVBVERSS  D

 ..;Check and be sure the new version isn't in the file yet

 ..S DVBABCN2=0,DVBABIE2=0,DVBACH=0

 ..F  S DVBABIE2=$O(^DVB(396.18,DVBABIE2)) Q:'DVBABIE2  D

 ...S DVBABS2=$P($G(^DVB(396.18,DVBABIE2,0)),"^",1)

 ...I $P(DVBABS2,"~",1)=NM  I $P(DVBABS2,"~",2)=DVBVERSN  S DVBACH=1

 ..;If new version is found, delete the import version and don't import

 ..I DVBACH=1  D

 ...W "FOUND EXISTING "_NM_".  NO MODIFICATIONS MADE.",!

 ...K ^DVB(396.18,DVBABIEN)

 ..;If existing version isn't found, go ahead and rename imported entry to new version name

 ..I DVBACH=0  D

 ...S $P(^DVB(396.18,DVBABIEN,0),"^",1)=NM_"~"_DVBVERSN

 ...W "ACTIVATED: "_$P($G(^DVB(396.18,DVBABIEN,0)),"^",1),!

 K DVBABCNT,DVBABIEN,DVBABST,DVBACH

 Q

RBXREF ;

 ; Rebuild cross-references

 ; XRef: B

 W !!,"CLEANING UP FILES AND REBUILDING 2 CROSS-REFERENCES.",!,"THIS MAY TAKE A FEW MINUTES.",!

 W !!,"REBUILDING 'B' XREF, CAPRI TEMPLATE DEFINITIONS FILE",!

 N DA,DIK,REGIEN,ROOT

 S ROOT=$$ROOT^DILFD(396.18,,1)  K @ROOT@("B")

 S REGIEN=0

 F  S REGIEN=$O(@ROOT@(REGIEN))  Q:'REGIEN  D

 . S DIK=$$ROOT^DILFD(396.18,","_REGIEN_","),DIK(1)=".01^B"

 . S DA(1)=REGIEN  D ENALL^DIK

 ; 

 ; XRef: AV

 W !!,"REBUILDING 'AV' XREF, CAPRI TEMPLATE DEFINITIONS FILE",!

 N DA,DIK,REGIEN,ROOT

 S ROOT=$$ROOT^DILFD(396.18,,1)  K @ROOT@("AV")

 S REGIEN=0

 F  S REGIEN=$O(@ROOT@(REGIEN))  Q:'REGIEN  D

 . S DIK=$$ROOT^DILFD(396.18,","_REGIEN_","),DIK(1)=".01^AV"

 . S DA(1)=REGIEN  D ENALL^DIK

 K DA,DIK,REGIEN,ROOT

 ;

 ; XRef: C, in 2507 EXAM FILE

 ;W !!,"REBUILDING 'C' XREF, 2507 EXAM FILE",!

 ;N DA,DIK,REGIEN,ROOT

 ;S ROOT=$$ROOT^DILFD(396.4,,1)  K @ROOT@("C")

 ;S REGIEN=0

 ;F  S REGIEN=$O(@ROOT@(REGIEN))  Q:'REGIEN  D

 ;. S DIK=$$ROOT^DILFD(396.4,","_REGIEN_","),DIK(1)=".02^C"

 ;. S DA(1)=REGIEN  D ENALL^DIK

 ;K DA,DIK,REGIEN,ROOT

 ;Q 

DISABLE(NM) ;

 ; First look for matches and turn off the "selectable by user field"

 ; This will keep the entry from showing in the list

 ; Next, look at disabled date.  If there's no date, set it to today.

 ; File is 396.18.  Field 3 is de-activation date.  Field 7 is selectable by user (0=no)

 N DVBABCNT,DVBABIEN,DVBABST,DVBACH

 S DVBABCNT=0,DVBABIEN=0

 F  S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN  D

 .S DVBABST=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)

 .I $P(DVBABST,"~",1)=NM  I $P(DVBABST,"~",2)'=DVBVERSN  D

 ..S DVBACH=0

 ..I $P(^DVB(396.18,DVBABIEN,6),"^",1)'="0"  S $P(^DVB(396.18,DVBABIEN,6),"^",1)="0",DVBACH=1

 ..I $P(^DVB(396.18,DVBABIEN,2),"^",2)=""  S $P(^DVB(396.18,DVBABIEN,2),"^",2)=DT,DVBACH=1  ; This is deactivation date 

 ..I DVBACH=1  W "MODIFIED: "_DVBABST,!

 K DVBABCNT,DVBABIEN,DVBABST,DVBACH

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBA2803   6097     printed  Feb 18, 2025@23:06:11                                                                                                                                                                                                    Page 2

DVBA2803  ;SPH - PATCH DRIVER ; 11/17/05

 +1       ;;2.7;AMIE;**103**;Apr 10, 1995

 +2       ;

 +3       ; Make sure to call each exam name being sent in the patch

 +4       ; This routine will find existing matching entries and will ensure they're disabled.

 +5       ; Call as a pre-init or else it'll disable the exams just loaded.

PRE       ;

 +1        NEW DVBVERSS,DVBVERSN

 +2       ; What the version will be in the incoming file

           SET DVBVERSS="103F"

 +3       ; What the final version should be named

           SET DVBVERSN="103T1"

 +4        WRITE !!!,"**** PRE-PROCESSING ****",!!

 +5        DO DISABLE("ACROMEGALY")

 +6        DO DISABLE("ARRHYTHMIAS")

 +7        DO DISABLE("ARTERIES, VEINS AND MISCELLANEOUS")

 +8        DO DISABLE("BRAIN AND SPINAL CORD")

 +9        DO DISABLE("COLD INJURY PROTOCOL EXAMINATION")

 +10       DO DISABLE("CRANIAL NERVES")

 +11       DO DISABLE("CUSHINGS SYNDROME")

 +12       DO DISABLE("DENTAL AND ORAL")

 +13       DO DISABLE("DIGESTIVE CONDITIONS, MISCELLANEOUS")

 +14       DO DISABLE("EATING DISORDERS")

 +15       DO DISABLE("EPILEPSY AND NARCOLEPSY")

 +16       DO DISABLE("ESOPHAGUS AND HIATAL HERNIA")

 +17       DO DISABLE("FIBROMYALGIA")

 +18       DO DISABLE("GULF WAR GUIDELINES")

 +19       DO DISABLE("GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST")

 +20       DO DISABLE("HIV-RELATED ILLNESS")

 +21       DO DISABLE("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")

 +22       DO DISABLE("INTESTINES (LARGE AND SMALL)")

 +23       DO DISABLE("LIVER, GALL BLADDER, AND PANCREAS")

 +24       DO DISABLE("LYMPHATIC DISORDERS")

 +25       DO DISABLE("MISCELLANEOUS ENDOCRINE DISEASES")

 +26       DO DISABLE("MOUTH, LIPS AND TONGUE")

 +27       DO DISABLE("PRISONER OF WAR PROTOCOL EXAMINATION")

 +28       DO DISABLE("PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES")

 +29       DO DISABLE("RECTUM AND ANUS")

 +30       DO DISABLE("RESIDUALS OF AMPUTATIONS")

 +31       DO DISABLE("SENSE OF SMELL AND TASTE")

 +32       DO DISABLE("SOCIAL WORK AND INDUSTRIAL SURVEY")

 +33       DO DISABLE("THYROID AND PARATHYROID DISEASES")

 +34       QUIT 

POST      ;

 +1        NEW DVBVERSS,DVBVERSN

 +2       ; What the version will be in the incoming file

           SET DVBVERSS="103F"

 +3       ; What the final version should be named

           SET DVBVERSN="103T1"

 +4        WRITE !!!,"**** POST-PROCESSING ****",!!

 +5        DO POSTP("ACROMEGALY")

 +6        DO POSTP("ARRHYTHMIAS")

 +7        DO POSTP("ARTERIES, VEINS AND MISCELLANEOUS")

 +8        DO POSTP("BRAIN AND SPINAL CORD")

 +9        DO POSTP("COLD INJURY PROTOCOL EXAMINATION")

 +10       DO POSTP("CRANIAL NERVES")

 +11       DO POSTP("CUSHINGS SYNDROME")

 +12       DO POSTP("DENTAL AND ORAL")

 +13       DO POSTP("DIGESTIVE CONDITIONS, MISCELLANEOUS")

 +14       DO POSTP("EATING DISORDERS")

 +15       DO POSTP("EPILEPSY AND NARCOLEPSY")

 +16       DO POSTP("ESOPHAGUS AND HIATAL HERNIA")

 +17       DO POSTP("FIBROMYALGIA")

 +18       DO POSTP("GULF WAR GUIDELINES")

 +19       DO POSTP("GYNECOLOGICAL CONDITIONS AND DISORDERS OF THE BREAST")

 +20       DO POSTP("HIV-RELATED ILLNESS")

 +21       DO POSTP("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")

 +22       DO POSTP("INTESTINES (LARGE AND SMALL)")

 +23       DO POSTP("LIVER, GALL BLADDER, AND PANCREAS")

 +24       DO POSTP("LYMPHATIC DISORDERS")

 +25       DO POSTP("MISCELLANEOUS ENDOCRINE DISEASES")

 +26       DO POSTP("MOUTH, LIPS AND TONGUE")

 +27       DO POSTP("PRISONER OF WAR PROTOCOL EXAMINATION")

 +28       DO POSTP("PULMONARY TUBERCULOSIS AND MYCOBACTERIAL DISEASES")

 +29       DO POSTP("RECTUM AND ANUS")

 +30       DO POSTP("RESIDUALS OF AMPUTATIONS")

 +31       DO POSTP("SENSE OF SMELL AND TASTE")

 +32       DO POSTP("SOCIAL WORK AND INDUSTRIAL SURVEY")

 +33       DO POSTP("THYROID AND PARATHYROID DISEASES")

 +34       DO RBXREF

 +35       QUIT 

POSTP(NM) ;

 +1       ; Rename XXXXXXX~imported version to XXXXXXX~new version

 +2        NEW DVBABCNT,DVBABIEN,DVBABST,DVBACH

 +3        NEW DVBABCN2,DVBABIE2,DVBABS2

 +4        SET DVBABCNT=0

           SET DVBABIEN=0

 +5        FOR 

               SET DVBABIEN=$ORDER(^DVB(396.18,DVBABIEN))

               if 'DVBABIEN

                   QUIT 

               Begin DoDot:1

 +6                SET DVBABST=$PIECE($GET(^DVB(396.18,DVBABIEN,0)),"^",1)

 +7                IF $PIECE(DVBABST,"~",1)=NM

                       IF $PIECE(DVBABST,"~",2)=DVBVERSS

                           Begin DoDot:2

 +8       ;Check and be sure the new version isn't in the file yet

 +9                            SET DVBABCN2=0

                               SET DVBABIE2=0

                               SET DVBACH=0

 +10                           FOR 

                                   SET DVBABIE2=$ORDER(^DVB(396.18,DVBABIE2))

                                   if 'DVBABIE2

                                       QUIT 

                                   Begin DoDot:3

 +11                                   SET DVBABS2=$PIECE($GET(^DVB(396.18,DVBABIE2,0)),"^",1)

 +12                                   IF $PIECE(DVBABS2,"~",1)=NM

                                           IF $PIECE(DVBABS2,"~",2)=DVBVERSN

                                               SET DVBACH=1

                                   End DoDot:3

 +13      ;If new version is found, delete the import version and don't import

 +14                           IF DVBACH=1

                                   Begin DoDot:3

 +15                                   WRITE "FOUND EXISTING "_NM_".  NO MODIFICATIONS MADE.",!

 +16                                   KILL ^DVB(396.18,DVBABIEN)

                                   End DoDot:3

 +17      ;If existing version isn't found, go ahead and rename imported entry to new version name

 +18                           IF DVBACH=0

                                   Begin DoDot:3

 +19                                   SET $PIECE(^DVB(396.18,DVBABIEN,0),"^",1)=NM_"~"_DVBVERSN

 +20                                   WRITE "ACTIVATED: "_$PIECE($GET(^DVB(396.18,DVBABIEN,0)),"^",1),!

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +21       KILL DVBABCNT,DVBABIEN,DVBABST,DVBACH

 +22       QUIT 

RBXREF    ;

 +1       ; Rebuild cross-references

 +2       ; XRef: B

 +3        WRITE !!,"CLEANING UP FILES AND REBUILDING 2 CROSS-REFERENCES.",!,"THIS MAY TAKE A FEW MINUTES.",!

 +4        WRITE !!,"REBUILDING 'B' XREF, CAPRI TEMPLATE DEFINITIONS FILE",!

 +5        NEW DA,DIK,REGIEN,ROOT

 +6        SET ROOT=$$ROOT^DILFD(396.18,,1)

           KILL @ROOT@("B")

 +7        SET REGIEN=0

 +8        FOR 

               SET REGIEN=$ORDER(@ROOT@(REGIEN))

               if 'REGIEN

                   QUIT 

               Begin DoDot:1

 +9                SET DIK=$$ROOT^DILFD(396.18,","_REGIEN_",")

                   SET DIK(1)=".01^B"

 +10               SET DA(1)=REGIEN

                   DO ENALL^DIK

               End DoDot:1

 +11      ; 

 +12      ; XRef: AV

 +13       WRITE !!,"REBUILDING 'AV' XREF, CAPRI TEMPLATE DEFINITIONS FILE",!

 +14       NEW DA,DIK,REGIEN,ROOT

 +15       SET ROOT=$$ROOT^DILFD(396.18,,1)

           KILL @ROOT@("AV")

 +16       SET REGIEN=0

 +17       FOR 

               SET REGIEN=$ORDER(@ROOT@(REGIEN))

               if 'REGIEN

                   QUIT 

               Begin DoDot:1

 +18               SET DIK=$$ROOT^DILFD(396.18,","_REGIEN_",")

                   SET DIK(1)=".01^AV"

 +19               SET DA(1)=REGIEN

                   DO ENALL^DIK

               End DoDot:1

 +20       KILL DA,DIK,REGIEN,ROOT

 +21      ;

 +22      ; XRef: C, in 2507 EXAM FILE

 +23      ;W !!,"REBUILDING 'C' XREF, 2507 EXAM FILE",!

 +24      ;N DA,DIK,REGIEN,ROOT

 +25      ;S ROOT=$$ROOT^DILFD(396.4,,1)  K @ROOT@("C")

 +26      ;S REGIEN=0

 +27      ;F  S REGIEN=$O(@ROOT@(REGIEN))  Q:'REGIEN  D

 +28      ;. S DIK=$$ROOT^DILFD(396.4,","_REGIEN_","),DIK(1)=".02^C"

 +29      ;. S DA(1)=REGIEN  D ENALL^DIK

 +30      ;K DA,DIK,REGIEN,ROOT

 +31      ;Q 

DISABLE(NM) ;

 +1       ; First look for matches and turn off the "selectable by user field"

 +2       ; This will keep the entry from showing in the list

 +3       ; Next, look at disabled date.  If there's no date, set it to today.

 +4       ; File is 396.18.  Field 3 is de-activation date.  Field 7 is selectable by user (0=no)

 +5        NEW DVBABCNT,DVBABIEN,DVBABST,DVBACH

 +6        SET DVBABCNT=0

           SET DVBABIEN=0

 +7        FOR 

               SET DVBABIEN=$ORDER(^DVB(396.18,DVBABIEN))

               if 'DVBABIEN

                   QUIT 

               Begin DoDot:1

 +8                SET DVBABST=$PIECE($GET(^DVB(396.18,DVBABIEN,0)),"^",1)

 +9                IF $PIECE(DVBABST,"~",1)=NM

                       IF $PIECE(DVBABST,"~",2)'=DVBVERSN

                           Begin DoDot:2

 +10                           SET DVBACH=0

 +11                           IF $PIECE(^DVB(396.18,DVBABIEN,6),"^",1)'="0"

                                   SET $PIECE(^DVB(396.18,DVBABIEN,6),"^",1)="0"

                                   SET DVBACH=1

 +12      ; This is deactivation date 

                               IF $PIECE(^DVB(396.18,DVBABIEN,2),"^",2)=""

                                   SET $PIECE(^DVB(396.18,DVBABIEN,2),"^",2)=DT

                                   SET DVBACH=1

 +13                           IF DVBACH=1

                                   WRITE "MODIFIED: "_DVBABST,!

                           End DoDot:2

               End DoDot:1

 +14       KILL DVBABCNT,DVBABIEN,DVBABST,DVBACH

 +15       QUIT