Routine: DVBA2795

DVBA2795 ;SPH - PATCH DRIVER ; 8/19/05

 ;;2.7;AMIE;**95**;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.

EN ;

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

 D DISABLE("RECTUM AND ANUS")

 D DISABLE("DIABETES MELLITUS")

 D DISABLE("ARTERIES, VEINS AND MISCELLANEOUS")

 D DISABLE("ACROMEGALY")

 D DISABLE("ARRHYTHMIAS")

 D DISABLE("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 D DISABLE("BRAIN AND SPINAL CORD")

 D DISABLE("HYPERTENSION")

 D DISABLE("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 D DISABLE("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")

 D DISABLE("DENTAL AND ORAL")

 D DISABLE("GULF WAR GUIDELINES")

 D DISABLE("EATING DISORDERS")

 D DISABLE("CRANIAL NERVES")

 D DISABLE("ESOPHAGUS AND HIATAL HERNIA")

 D DISABLE("AUDIO")

 D DISABLE("EYE EXAMINATION")

 D DISABLE("SKIN DISEASES (OTHER THAN SCARS)")

 D DISABLE("FEET")

 D MENTALUP

POST ;

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

 D POSTP("RECTUM AND ANUS")

 D POSTP("DIABETES MELLITUS")

 D POSTP("ARTERIES, VEINS AND MISCELLANEOUS")

 D POSTP("ACROMEGALY")

 D POSTP("ARRHYTHMIAS")

 D POSTP("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 D POSTP("BRAIN AND SPINAL CORD")

 D POSTP("HYPERTENSION")

 D POSTP("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 D POSTP("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")

 D POSTP("DENTAL AND ORAL")

 D POSTP("GULF WAR GUIDELINES")

 D POSTP("EATING DISORDERS")

 D POSTP("CRANIAL NERVES")

 D POSTP("ESOPHAGUS AND HIATAL HERNIA")

 D POSTP("AUDIO")

 D POSTP("EYE EXAMINATION")

 D POSTP("SKIN DISEASES (OTHER THAN SCARS)")

 D POSTP("FEET")

 D RBXREF

POSTP(NM) ;

 ; Rename XXXXXXX~95F to XXXXXXX~95

 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)="95F"  D

 ..;Check and be sure a 95 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)="95"  S DVBACH=1

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

 ..I DVBACH=1  D

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

 ...K ^DVB(396.18,DVBABIEN)

 ..;If 95 version isn't found, go ahead and rename new 95F to 95

 ..I DVBACH=0  D

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

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

 K DVBABCNT,DVBABIEN,DVBABST,DVBACH

RBXREF ;

 ; Rebuild cross-references

 ; XRef: B

 W !!,"REBUILDING 'B' XREF",!

 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",!

 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

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)'="95"  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

MENTALUP ;

 ; Update mental health exam

 ; Turn off V89 and turn on V92

 W !!,"CHECKING MENTAL DISORDERS...",!!

 N DVBABCNT,DVBABIEN,DVBABST,NM,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)

 .S NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~89"

 .I $P(DVBABST,"^",1)=NM  D

 ..S DVBACH=0

 ..I $P(^DVB(396.18,DVBABIEN,6),"^",1)'="0"  S $P(^DVB(396.18,DVBABIEN,6),"^",1)="0",DVBACH=1 ; Turn off selectable by user

 ..I $P(^DVB(396.18,DVBABIEN,2),"^",2)=""  S $P(^DVB(396.18,DVBABIEN,2),"^",2)=DT,DVHACH=1 ; Turn on deactivation date

 ..I DVBACH=1  W "TURNED OFF V89 OF MENTAL DISORDERS EXAM",!

 .S NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~92"

 .I $P(DVBABST,"^",1)=NM  D

 ..S DVBACH=0

 ..I $P(^DVB(396.18,DVBABIEN,6),"^",1)'="1"  S $P(^DVB(396.18,DVBABIEN,6),"^",1)="1",DVBACH=1 ; Turn on selectable by user

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

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

 ..I DVBACH=1  W "TURNED ON V92 OF MENTAL DISORDERS EXAM",!

 K DVBABCNT,DVBABIEN,DVBABST,NM,DVBACH

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA2795   5595     printed  Mar 13, 2025@20:44:25                                                                                                                                                                                                    Page 2

DVBA2795  ;SPH - PATCH DRIVER ; 8/19/05

 +1       ;;2.7;AMIE;**95**;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.

EN        ;

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

 +2        DO DISABLE("RECTUM AND ANUS")

 +3        DO DISABLE("DIABETES MELLITUS")

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

 +5        DO DISABLE("ACROMEGALY")

 +6        DO DISABLE("ARRHYTHMIAS")

 +7        DO DISABLE("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

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

 +9        DO DISABLE("HYPERTENSION")

 +10       DO DISABLE("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 +11       DO DISABLE("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")

 +12       DO DISABLE("DENTAL AND ORAL")

 +13       DO DISABLE("GULF WAR GUIDELINES")

 +14       DO DISABLE("EATING DISORDERS")

 +15       DO DISABLE("CRANIAL NERVES")

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

 +17       DO DISABLE("AUDIO")

 +18       DO DISABLE("EYE EXAMINATION")

 +19       DO DISABLE("SKIN DISEASES (OTHER THAN SCARS)")

 +20       DO DISABLE("FEET")

 +21       DO MENTALUP

 +22       QUIT

POST      ;

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

 +2        DO POSTP("RECTUM AND ANUS")

 +3        DO POSTP("DIABETES MELLITUS")

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

 +5        DO POSTP("ACROMEGALY")

 +6        DO POSTP("ARRHYTHMIAS")

 +7        DO POSTP("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

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

 +9        DO POSTP("HYPERTENSION")

 +10       DO POSTP("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")

 +11       DO POSTP("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")

 +12       DO POSTP("DENTAL AND ORAL")

 +13       DO POSTP("GULF WAR GUIDELINES")

 +14       DO POSTP("EATING DISORDERS")

 +15       DO POSTP("CRANIAL NERVES")

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

 +17       DO POSTP("AUDIO")

 +18       DO POSTP("EYE EXAMINATION")

 +19       DO POSTP("SKIN DISEASES (OTHER THAN SCARS)")

 +20       DO POSTP("FEET")

 +21       DO RBXREF

 +22       QUIT

POSTP(NM) ;

 +1       ; Rename XXXXXXX~95F to XXXXXXX~95

 +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)="95F"

                           Begin DoDot:2

 +8       ;Check and be sure a 95 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)="95"

                                               SET DVBACH=1

                                   End DoDot:3

 +13      ;If 95 version is found, delete new 95F 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 95 version isn't found, go ahead and rename new 95F to 95

 +18                           IF DVBACH=0

                                   Begin DoDot:3

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

 +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 !!,"REBUILDING 'B' XREF",!

 +4        NEW DA,DIK,REGIEN,ROOT

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

           KILL @ROOT@("B")

 +6        SET REGIEN=0

 +7        FOR

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

               if 'REGIEN

                   QUIT

               Begin DoDot:1

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

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

 +9                SET DA(1)=REGIEN

                   DO ENALL^DIK

               End DoDot:1

 +10      ;

 +11      ; XRef: AV

 +12       WRITE !!,"REBUILDING 'AV' XREF",!

 +13       NEW DA,DIK,REGIEN,ROOT

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

           KILL @ROOT@("AV")

 +15       SET REGIEN=0

 +16       FOR

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

               if 'REGIEN

                   QUIT

               Begin DoDot:1

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

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

 +18               SET DA(1)=REGIEN

                   DO ENALL^DIK

               End DoDot:1

 +19       KILL DA,DIK,REGIEN,ROOT

 +20       QUIT

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)'="95"

                           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

MENTALUP  ;

 +1       ; Update mental health exam

 +2       ; Turn off V89 and turn on V92

 +3        WRITE !!,"CHECKING MENTAL DISORDERS...",!!

 +4        NEW DVBABCNT,DVBABIEN,DVBABST,NM,DVBACH

 +5        SET DVBABCNT=0

           SET DVBABIEN=0

 +6        FOR

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

               if 'DVBABIEN

                   QUIT

               Begin DoDot:1

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

 +8                SET NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~89"

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

                       Begin DoDot:2

 +10                       SET DVBACH=0

 +11      ; Turn off selectable by user

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

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

                               SET DVBACH=1

 +12      ; Turn on deactivation date

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

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

                               SET DVHACH=1

 +13                       IF DVBACH=1

                               WRITE "TURNED OFF V89 OF MENTAL DISORDERS EXAM",!

                       End DoDot:2

 +14               SET NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~92"

 +15               IF $PIECE(DVBABST,"^",1)=NM

                       Begin DoDot:2

 +16                       SET DVBACH=0

 +17      ; Turn on selectable by user

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

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

                               SET DVBACH=1

 +18      ; This is activation date

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

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

                               SET DVBACH=1

 +19      ; This is deactivation date

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

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

                               SET DVBACH=1

 +20                       IF DVBACH=1

                               WRITE "TURNED ON V92 OF MENTAL DISORDERS EXAM",!

                       End DoDot:2

               End DoDot:1

 +21       KILL DVBABCNT,DVBABIEN,DVBABST,NM,DVBACH

 +22       QUIT

DVBA2795.m