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
Q
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
Q
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
Q
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
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)'="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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA2795 5595 printed Dec 13, 2024@01:39:45 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