- 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 Jan 18, 2025@02:41:07 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**