source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBA2795.m@ 1789

Last change on this file since 1789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1DVBA2795 ;SPH - PATCH DRIVER ; 8/19/05
2 ;;2.7;AMIE;**95**;Apr 10, 1995
3 ;
4 ; Make sure to call each exam name being sent in the patch
5 ; This routine will find existing matching entries and will ensure they're disabled.
6 ; Call as a pre-init or else it'll disable the exams just loaded.
7EN ;
8 W !!!,"**** PRE-PROCESSING ****",!!
9 D DISABLE("RECTUM AND ANUS")
10 D DISABLE("DIABETES MELLITUS")
11 D DISABLE("ARTERIES, VEINS AND MISCELLANEOUS")
12 D DISABLE("ACROMEGALY")
13 D DISABLE("ARRHYTHMIAS")
14 D DISABLE("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")
15 D DISABLE("BRAIN AND SPINAL CORD")
16 D DISABLE("HYPERTENSION")
17 D DISABLE("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")
18 D DISABLE("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")
19 D DISABLE("DENTAL AND ORAL")
20 D DISABLE("GULF WAR GUIDELINES")
21 D DISABLE("EATING DISORDERS")
22 D DISABLE("CRANIAL NERVES")
23 D DISABLE("ESOPHAGUS AND HIATAL HERNIA")
24 D DISABLE("AUDIO")
25 D DISABLE("EYE EXAMINATION")
26 D DISABLE("SKIN DISEASES (OTHER THAN SCARS)")
27 D DISABLE("FEET")
28 D MENTALUP
29 Q
30POST ;
31 W !!!,"**** POST-PROCESSING ****",!!
32 D POSTP("RECTUM AND ANUS")
33 D POSTP("DIABETES MELLITUS")
34 D POSTP("ARTERIES, VEINS AND MISCELLANEOUS")
35 D POSTP("ACROMEGALY")
36 D POSTP("ARRHYTHMIAS")
37 D POSTP("REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")
38 D POSTP("BRAIN AND SPINAL CORD")
39 D POSTP("HYPERTENSION")
40 D POSTP("INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)")
41 D POSTP("RESPIRATORY (OBSTRUCTIVE, RESTRICTIVE, AND INTERSTITIAL)")
42 D POSTP("DENTAL AND ORAL")
43 D POSTP("GULF WAR GUIDELINES")
44 D POSTP("EATING DISORDERS")
45 D POSTP("CRANIAL NERVES")
46 D POSTP("ESOPHAGUS AND HIATAL HERNIA")
47 D POSTP("AUDIO")
48 D POSTP("EYE EXAMINATION")
49 D POSTP("SKIN DISEASES (OTHER THAN SCARS)")
50 D POSTP("FEET")
51 D RBXREF
52 Q
53POSTP(NM) ;
54 ; Rename XXXXXXX~95F to XXXXXXX~95
55 N DVBABCNT,DVBABIEN,DVBABST,DVBACH
56 N DVBABCN2,DVBABIE2,DVBABS2
57 S DVBABCNT=0,DVBABIEN=0
58 F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN D
59 .S DVBABST=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)
60 .I $P(DVBABST,"~",1)=NM I $P(DVBABST,"~",2)="95F" D
61 ..;Check and be sure a 95 version isn't in the file yet
62 ..S DVBABCN2=0,DVBABIE2=0,DVBACH=0
63 ..F S DVBABIE2=$O(^DVB(396.18,DVBABIE2)) Q:'DVBABIE2 D
64 ...S DVBABS2=$P($G(^DVB(396.18,DVBABIE2,0)),"^",1)
65 ...I $P(DVBABS2,"~",1)=NM I $P(DVBABS2,"~",2)="95" S DVBACH=1
66 ..;If 95 version is found, delete new 95F version and don't import
67 ..I DVBACH=1 D
68 ...W "FOUND EXISTING "_NM_". NO MODIFICATIONS MADE.",!
69 ...K ^DVB(396.18,DVBABIEN)
70 ..;If 95 version isn't found, go ahead and rename new 95F to 95
71 ..I DVBACH=0 D
72 ...S $P(^DVB(396.18,DVBABIEN,0),"^",1)=NM_"~95"
73 ...W "ACTIVATED: "_$P($G(^DVB(396.18,DVBABIEN,0)),"^",1),!
74 K DVBABCNT,DVBABIEN,DVBABST,DVBACH
75 Q
76RBXREF ;
77 ; Rebuild cross-references
78 ; XRef: B
79 W !!,"REBUILDING 'B' XREF",!
80 N DA,DIK,REGIEN,ROOT
81 S ROOT=$$ROOT^DILFD(396.18,,1) K @ROOT@("B")
82 S REGIEN=0
83 F S REGIEN=$O(@ROOT@(REGIEN)) Q:'REGIEN D
84 . S DIK=$$ROOT^DILFD(396.18,","_REGIEN_","),DIK(1)=".01^B"
85 . S DA(1)=REGIEN D ENALL^DIK
86 ;
87 ; XRef: AV
88 W !!,"REBUILDING 'AV' XREF",!
89 N DA,DIK,REGIEN,ROOT
90 S ROOT=$$ROOT^DILFD(396.18,,1) K @ROOT@("AV")
91 S REGIEN=0
92 F S REGIEN=$O(@ROOT@(REGIEN)) Q:'REGIEN D
93 . S DIK=$$ROOT^DILFD(396.18,","_REGIEN_","),DIK(1)=".01^AV"
94 . S DA(1)=REGIEN D ENALL^DIK
95 K DA,DIK,REGIEN,ROOT
96 Q
97DISABLE(NM) ;
98 ; First look for matches and turn off the "selectable by user field"
99 ; This will keep the entry from showing in the list
100 ; Next, look at disabled date. If there's no date, set it to today.
101 ; File is 396.18. Field 3 is de-activation date. Field 7 is selectable by user (0=no)
102 N DVBABCNT,DVBABIEN,DVBABST,DVBACH
103 S DVBABCNT=0,DVBABIEN=0
104 F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN D
105 .S DVBABST=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)
106 .I $P(DVBABST,"~",1)=NM I $P(DVBABST,"~",2)'="95" D
107 ..S DVBACH=0
108 ..I $P(^DVB(396.18,DVBABIEN,6),"^",1)'="0" S $P(^DVB(396.18,DVBABIEN,6),"^",1)="0",DVBACH=1
109 ..I $P(^DVB(396.18,DVBABIEN,2),"^",2)="" S $P(^DVB(396.18,DVBABIEN,2),"^",2)=DT,DVBACH=1 ; This is deactivation date
110 ..I DVBACH=1 W "MODIFIED: "_DVBABST,!
111 K DVBABCNT,DVBABIEN,DVBABST,DVBACH
112 Q
113MENTALUP ;
114 ; Update mental health exam
115 ; Turn off V89 and turn on V92
116 W !!,"CHECKING MENTAL DISORDERS...",!!
117 N DVBABCNT,DVBABIEN,DVBABST,NM,DVBACH
118 S DVBABCNT=0,DVBABIEN=0
119 F S DVBABIEN=$O(^DVB(396.18,DVBABIEN)) Q:'DVBABIEN D
120 .S DVBABST=$P($G(^DVB(396.18,DVBABIEN,0)),"^",1)
121 .S NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~89"
122 .I $P(DVBABST,"^",1)=NM D
123 ..S DVBACH=0
124 ..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
125 ..I $P(^DVB(396.18,DVBABIEN,2),"^",2)="" S $P(^DVB(396.18,DVBABIEN,2),"^",2)=DT,DVHACH=1 ; Turn on deactivation date
126 ..I DVBACH=1 W "TURNED OFF V89 OF MENTAL DISORDERS EXAM",!
127 .S NM="MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~92"
128 .I $P(DVBABST,"^",1)=NM D
129 ..S DVBACH=0
130 ..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
131 ..I $P(^DVB(396.18,DVBABIEN,2),"^",1)="" S $P(^DVB(396.18,DVBABIEN,2),"^",1)=DT,DVBACH=1 ; This is activation date
132 ..I $P(^DVB(396.18,DVBABIEN,2),"^",2)'="" S $P(^DVB(396.18,DVBABIEN,2),"^",2)="",DVBACH=1 ; This is deactivation date
133 ..I DVBACH=1 W "TURNED ON V92 OF MENTAL DISORDERS EXAM",!
134 K DVBABCNT,DVBABIEN,DVBABST,NM,DVBACH
135 Q
Note: See TracBrowser for help on using the repository browser.