DVBA2814 ;ALB/SPH - PATCH DRIVER ; 2/12/07
;;2.7;AMIE;**114**;Apr 10, 1995;Build 10
;
; Make sure to call each exam name being sent in the patch
; This routine will find existing matching entries and will ensure
; they are disabled.
; Call as a pre-init or else it'll disable the exams just loaded.
PRE ;
N DVBVERSS,DVBVERSN
;
;rename 114 to 114T1 for test sites to allow final build to load
D RENAME("114","114T1")
;
S DVBVERSS="114F" ; What the version will be in the incoming file
S DVBVERSN="114" ; What the final version should be named
W !!!,"**** PRE-PROCESSING ****",!!
D DISABLE("DIABETES MELLITUS")
D DISABLE("EATING DISORDERS")
D DISABLE("FEET")
D DISABLE("GENERAL MEDICAL EXAMINATION")
D DISABLE("GENITOURINARY EXAMINATION")
D DISABLE("GULF WAR GUIDELINES")
D DISABLE("HIV-RELATED ILLNESS")
D DISABLE("HYPERTENSION")
D DISABLE("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")
D DISABLE("PERIPHERAL NERVES")
D DISABLE("PRISONER OF WAR PROTOCOL EXAMINATION")
D DISABLE("RECTUM AND ANUS")
D DISABLE("RESPIRATORY DISEASES, MISCELLANEOUS")
D DISABLE("SKIN DISEASES (OTHER THAN SCARS)")
D DISABLE("SPINE")
Q
POST ;
N DVBVERSS,DVBVERSN
S DVBVERSS="114F" ; What the version will be in the incoming file
S DVBVERSN="114" ; What the final version should be named
W !!!,"**** POST-PROCESSING ****",!!
D POSTP("DIABETES MELLITUS")
D POSTP("EATING DISORDERS")
D POSTP("FEET")
D POSTP("GENERAL MEDICAL EXAMINATION")
D POSTP("GENITOURINARY EXAMINATION")
D POSTP("GULF WAR GUIDELINES")
D POSTP("HIV-RELATED ILLNESS")
D POSTP("HYPERTENSION")
D POSTP("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")
D POSTP("PERIPHERAL NERVES")
D POSTP("PRISONER OF WAR PROTOCOL EXAMINATION")
D POSTP("RECTUM AND ANUS")
D POSTP("RESPIRATORY DISEASES, MISCELLANEOUS")
D POSTP("SKIN DISEASES (OTHER THAN SCARS)")
D POSTP("SPINE")
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
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
;
RENAME(DVBOLD,DVBNEW) ;rename templates
;This procedure searches for any version DVBOLD template definitions
;that have a non-zero deactivation date and renames them to DVBNEW.
;No action is taken when any of the following conditions exist:
; * Deactivation date is not defined
; * A version DVBNEW template already exists.
;
; Input:
; DVBOLD - old version name
; DVBNEW - new version name
;
; Output: none
;
N DVBERR ;DBS error message array
N DVBI ;generic index
N DVBIEN ;pointer to #396.18
N DVBTNAM ;template name
;
F DVBI=1:1 S DVBTNAM=$P($T(TLIST+DVBI),";",3) Q:DVBTNAM="**END**" D
. S DVBIEN=$$FIND1^DIC(396.18,"","X",DVBTNAM_"~"_DVBOLD,"B","","DVBERR")
. I DVBIEN,+$$GET1^DIQ(396.18,DVBIEN_",",3,"I","","DVBERR")>0 D
. . N DVBFDA ;filer FDA array
. . ;
. . ;short-circuit when new version exists
. . Q:$$FIND1^DIC(396.18,"","X",DVBTNAM_"~"_DVBNEW,"B","","DVBERR")
. . ;
. . ;rename it
. . S DVBFDA(396.18,DVBIEN_",",.01)=DVBTNAM_"~"_DVBNEW
. . D FILE^DIE("E","DVBFDA","DVBERR")
;
Q
;
TLIST ;;TEMPLATE LIST
;;DIABETES MELLITUS
;;EATING DISORDERS
;;FEET
;;GENERAL MEDICAL EXAMINATION
;;GENITOURINARY EXAMINATION
;;GULF WAR GUIDELINES
;;HIV-RELATED ILLNESS
;;HYPERTENSION
;;INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES
;;PERIPHERAL NERVES
;;PRISONER OF WAR PROTOCOL EXAMINATION
;;RECTUM AND ANUS
;;RESPIRATORY DISEASES, MISCELLANEOUS
;;SKIN DISEASES (OTHER THAN SCARS)
;;SPINE
;;**END**
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA2814 6157 printed Apr 09, 2024@20:47:53 Page 2
DVBA2814 ;ALB/SPH - PATCH DRIVER ; 2/12/07
+1 ;;2.7;AMIE;**114**;Apr 10, 1995;Build 10
+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
+5 ; they are disabled.
+6 ; Call as a pre-init or else it'll disable the exams just loaded.
PRE ;
+1 NEW DVBVERSS,DVBVERSN
+2 ;
+3 ;rename 114 to 114T1 for test sites to allow final build to load
+4 DO RENAME("114","114T1")
+5 ;
+6 ; What the version will be in the incoming file
SET DVBVERSS="114F"
+7 ; What the final version should be named
SET DVBVERSN="114"
+8 WRITE !!!,"**** PRE-PROCESSING ****",!!
+9 DO DISABLE("DIABETES MELLITUS")
+10 DO DISABLE("EATING DISORDERS")
+11 DO DISABLE("FEET")
+12 DO DISABLE("GENERAL MEDICAL EXAMINATION")
+13 DO DISABLE("GENITOURINARY EXAMINATION")
+14 DO DISABLE("GULF WAR GUIDELINES")
+15 DO DISABLE("HIV-RELATED ILLNESS")
+16 DO DISABLE("HYPERTENSION")
+17 DO DISABLE("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")
+18 DO DISABLE("PERIPHERAL NERVES")
+19 DO DISABLE("PRISONER OF WAR PROTOCOL EXAMINATION")
+20 DO DISABLE("RECTUM AND ANUS")
+21 DO DISABLE("RESPIRATORY DISEASES, MISCELLANEOUS")
+22 DO DISABLE("SKIN DISEASES (OTHER THAN SCARS)")
+23 DO DISABLE("SPINE")
+24 QUIT
POST ;
+1 NEW DVBVERSS,DVBVERSN
+2 ; What the version will be in the incoming file
SET DVBVERSS="114F"
+3 ; What the final version should be named
SET DVBVERSN="114"
+4 WRITE !!!,"**** POST-PROCESSING ****",!!
+5 DO POSTP("DIABETES MELLITUS")
+6 DO POSTP("EATING DISORDERS")
+7 DO POSTP("FEET")
+8 DO POSTP("GENERAL MEDICAL EXAMINATION")
+9 DO POSTP("GENITOURINARY EXAMINATION")
+10 DO POSTP("GULF WAR GUIDELINES")
+11 DO POSTP("HIV-RELATED ILLNESS")
+12 DO POSTP("HYPERTENSION")
+13 DO POSTP("INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES")
+14 DO POSTP("PERIPHERAL NERVES")
+15 DO POSTP("PRISONER OF WAR PROTOCOL EXAMINATION")
+16 DO POSTP("RECTUM AND ANUS")
+17 DO POSTP("RESPIRATORY DISEASES, MISCELLANEOUS")
+18 DO POSTP("SKIN DISEASES (OTHER THAN SCARS)")
+19 DO POSTP("SPINE")
+20 DO RBXREF
+21 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 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)'=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
+16 ;
RENAME(DVBOLD,DVBNEW) ;rename templates
+1 ;This procedure searches for any version DVBOLD template definitions
+2 ;that have a non-zero deactivation date and renames them to DVBNEW.
+3 ;No action is taken when any of the following conditions exist:
+4 ; * Deactivation date is not defined
+5 ; * A version DVBNEW template already exists.
+6 ;
+7 ; Input:
+8 ; DVBOLD - old version name
+9 ; DVBNEW - new version name
+10 ;
+11 ; Output: none
+12 ;
+13 ;DBS error message array
NEW DVBERR
+14 ;generic index
NEW DVBI
+15 ;pointer to #396.18
NEW DVBIEN
+16 ;template name
NEW DVBTNAM
+17 ;
+18 FOR DVBI=1:1
SET DVBTNAM=$PIECE($TEXT(TLIST+DVBI),";",3)
if DVBTNAM="**END**"
QUIT
Begin DoDot:1
+19 SET DVBIEN=$$FIND1^DIC(396.18,"","X",DVBTNAM_"~"_DVBOLD,"B","","DVBERR")
+20 IF DVBIEN
IF +$$GET1^DIQ(396.18,DVBIEN_",",3,"I","","DVBERR")>0
Begin DoDot:2
+21 ;filer FDA array
NEW DVBFDA
+22 ;
+23 ;short-circuit when new version exists
+24 if $$FIND1^DIC(396.18,"","X",DVBTNAM_"~"_DVBNEW,"B","","DVBERR")
QUIT
+25 ;
+26 ;rename it
+27 SET DVBFDA(396.18,DVBIEN_",",.01)=DVBTNAM_"~"_DVBNEW
+28 DO FILE^DIE("E","DVBFDA","DVBERR")
End DoDot:2
End DoDot:1
+29 ;
+30 QUIT
+31 ;
TLIST ;;TEMPLATE LIST
+1 ;;DIABETES MELLITUS
+2 ;;EATING DISORDERS
+3 ;;FEET
+4 ;;GENERAL MEDICAL EXAMINATION
+5 ;;GENITOURINARY EXAMINATION
+6 ;;GULF WAR GUIDELINES
+7 ;;HIV-RELATED ILLNESS
+8 ;;HYPERTENSION
+9 ;;INFECTIOUS, IMMUNE, AND NUTRITIONAL DISABILITIES
+10 ;;PERIPHERAL NERVES
+11 ;;PRISONER OF WAR PROTOCOL EXAMINATION
+12 ;;RECTUM AND ANUS
+13 ;;RESPIRATORY DISEASES, MISCELLANEOUS
+14 ;;SKIN DISEASES (OTHER THAN SCARS)
+15 ;;SPINE
+16 ;;**END**
