source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAIPST3.m@ 808

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RAIPST3 ;HIRMFO/GJC - Clean-up of the v5.0 environment ;10/9/97 14:40
2VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3 S ZTREQ="@" ; delete from the task global
4 I +$G(DIFROM)'=+$P($T(VERSION),";",3) S XPDABORT=2 Q
5 N RAIPST
6 ;
7 S RAIPST=$$NEWCP^XPDUTL("PST31","NUMLIN^RAIPST3")
8 ; This subroutine will delete the Number Of Lines field (12)
9 ; and all associated data from the Rad/Nuc Med Reports file (74)
10 ;
11 S RAIPST=$$NEWCP^XPDUTL("PST32","TCOMNTS^RAIPST3")
12 ; This subroutine will delete the Transfer Comment field (150)
13 ; and all associated data from the Examinations Sub-Field
14 ; (70.03)
15 ;
16 S RAIPST=$$NEWCP^XPDUTL("PST33","DISTQ^RAIPST3")
17 ; This subroutine will delete the following fields from the
18 ; Report Distribution (74.4) file: Hospital Division (5)
19 ; Imaging Location (7), Patient (9) and SSN (10). All data
20 ; associated with these fields will be deleted.
21 ;
22 S RAIPST=$$NEWCP^XPDUTL("PST34","TIMOUT^RAIPST3")
23 ; This subroutine will delete the '*Timeout After How
24 ; Many Second' field from the Imaging Type (79.2) file.
25 ; All data associated with this field will be deleted.
26 ;
27 S RAIPST=$$NEWCP^XPDUTL("PST35","AOXREF^RAIPST3")
28 ; This subroutine will delete corrupted "AO" cross-
29 ; reference data from the Rad/Nuc Med Patient file.
30 ; Only the "AO" cross-reference will be deleted. Data
31 ; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
32 ; Orders file will remain intact.
33 ;
34NUMLIN ; This subroutine will delete the Number Of Lines field (12)
35 ; and all associated data in the Rad/Nuc Med Reports file (74)
36 Q:'($D(^DD(74,12,0))#2) ; Done in the past
37 N %,DA,DIC,DIK,RA1,RACNT,RAD0,RALNUM,RATXT,X,Y
38 S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST31")
39 S RATXT(2)="Deleting obsolete NUMBER OF LINES field from Rad/Nuc Med"
40 S RATXT(3)="Reports data dictionary. Deleting Number of Lines data"
41 S RATXT(4)="from the Rad/Nuc Med Reports file. Please be patient,"
42 S RATXT(5)="this may take awhile." D BMES^XPDUTL(.RATXT)
43 F S RAD0=$O(^RARPT(RAD0)) Q:RAD0'>0 D
44 . S RALNUM=$P($G(^RARPT(RAD0,"T")),"^",2)
45 . D:RALNUM]"" ENKILL^RAXREF(74,12,RALNUM,.RAD0)
46 . S:RALNUM]"" $P(^RARPT(RAD0,"T"),"^",2)=""
47 . S RACNT=+$G(RACNT)+1
48 . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
49 . S RA1=+$$UPCP^XPDUTL("PST31",RAD0)
50 . Q
51 S DIK="^DD(74,",DA(1)=74,DA=12 D ^DIK ; delete from data dictionary
52 Q
53TCOMNTS ; This subroutine will delete the Transfer Comment field (150)
54 ; and all associated data from the Examinations Sub-Field (70.03)
55 Q:'($D(^DD(70.03,150,0))#2) ; Done in the past
56 N %,DA,DIC,DIK,RA1,RACNI,RACNT,RADA,RADFN,RADTI,RATCOM,RATXT,X,Y
57 S RATXT(1)=" ",RADFN=+$$PARCP^XPDUTL("PST32")
58 S RATXT(2)="Deleting obsolete TRANSFER COMMENT field from Examinations sub-file"
59 S RATXT(3)="data dictionary. Deleting the Transfer Comment data from the Rad/Nuc"
60 S RATXT(4)="Med Patient file. Please be patient, this may take awhile."
61 D BMES^XPDUTL(.RATXT)
62 F S RADFN=$O(^RADPT(RADFN)) Q:RADFN'>0 D
63 . S RADTI=0 F S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 D
64 .. S RACNI=0
65 .. F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D
66 ... S RATCOM=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")),"^")
67 ... I RATCOM]"" D
68 .... S RADA(2)=RADFN,RADA(1)=RADTI,RADA=RACNI
69 .... D ENKILL^RAXREF(70.03,150,RATCOM,.RADA)
70 .... Q
71 ... K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")
72 ... Q
73 .. Q
74 . S RACNT=+$G(RACNT)+1
75 . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
76 . S RA1=+$$UPCP^XPDUTL("PST32",RADFN)
77 . Q
78 S DIK="^DD(70.03,",DA(1)=70.03,DA=150
79 D ^DIK ; delete the data dictionary
80 Q
81DISTQ ; This subroutine will delete the following fields from the
82 ; Report Distribution (74.4) file: Hospital Division (5)
83 ; Imaging Location (7), Patient (9) and SSN (10). All data
84 ; associated with these fields will be deleted.
85 Q:'($D(^DD(74.4,10,0))#2) ; Done in the past, this is the last field
86 ; deleted.
87 N %,DA,DIC,DIK,RA1,RA744,RACNT,RAD0,RAHD,RAIL,RAPAT,RASSN,RATXT,X,Y
88 S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST33")
89 S RATXT(2)="Deleting the following obsolete fields and data from the"
90 S RATXT(3)="Report Distribution data dictionary:"
91 S RATXT(4)="HOSPITAL DIVISION, IMAGING LOCATION, PATIENT and SSN."
92 D BMES^XPDUTL(.RATXT)
93 F S RAD0=$O(^RABTCH(74.4,RAD0)) Q:RAD0'>0 D
94 . S RA744=$G(^RABTCH(74.4,RAD0,0)),RAHD=$P(RA744,"^",5)
95 . S RAIL=$P(RA744,"^",7),RAPAT=$P(RA744,"^",9),RASSN=$P(RA744,"^",10)
96 . I RAHD]"" D
97 .. D ENKILL^RAXREF(74.4,5,RAHD,.RAD0)
98 .. S $P(^RABTCH(74.4,RAD0,0),"^",5)=""
99 .. Q
100 . I RAIL]"" D
101 .. D ENKILL^RAXREF(74.4,7,RAIL,.RAD0)
102 .. S $P(^RABTCH(74.4,RAD0,0),"^",7)=""
103 .. Q
104 . I RAPAT]"" D
105 .. D ENKILL^RAXREF(74.4,9,RAPAT,.RAD0)
106 .. S $P(^RABTCH(74.4,RAD0,0),"^",9)=""
107 .. Q
108 . I RASSN]"" D
109 .. D ENKILL^RAXREF(74.4,10,RASSN,.RAD0)
110 .. S $P(^RABTCH(74.4,RAD0,0),"^",10)=""
111 .. Q
112 . S RACNT=+$G(RACNT)+1
113 . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
114 . S RA1=+$$UPCP^XPDUTL("PST33",RAD0)
115 . Q
116 ; delete the fields one at a time.
117 S DIK="^DD(74.4,",DA(1)=74.4,DA=5 D ^DIK K %,DA,DIC,DIK
118 S DIK="^DD(74.4,",DA(1)=74.4,DA=7 D ^DIK K %,DA,DIC,DIK
119 S DIK="^DD(74.4,",DA(1)=74.4,DA=9 D ^DIK K %,DA,DIC,DIK
120 S DIK="^DD(74.4,",DA(1)=74.4,DA=10 D ^DIK K %,DA,DIC,DIK
121 Q
122TIMOUT ; This subroutine will delete the '*Timeout After How
123 ; Many Second' field from the Imaging Type (79.2) file.
124 ; All data associated with this field will be deleted.
125 Q:'($D(^DD(79.2,2,0))#2) ; Done in the past
126 N %,DA,DIC,DIK,RAD0,RASEC,RATXT,X,Y S RATXT(1)=" "
127 S RATXT(2)="Deleting obsolete *TIMEOUT AFTER HOW MANY SECOND field and data from"
128 S RATXT(3)="the Imaging Type file."
129 D MES^XPDUTL(.RATXT) S RAD0=0
130 F S RAD0=$O(^RA(79.2,RAD0)) Q:RAD0'>0 D
131 . S RASEC=$P($G(^RA(79.2,RAD0,0)),"^",2)
132 . D:RASEC]"" ENKILL^RAXREF(79.2,2,RASEC,.RAD0)
133 . S:RASEC]"" $P(^RA(79.2,RAD0,0),"^",2)=""
134 . Q
135 S DIK="^DD(79.2,",DA(1)=79.2,DA=2 D ^DIK K %,DA,DIC,DIK ; remove field
136 Q
137AOXREF ; This subroutine will delete corrupted "AO" cross-
138 ; reference data from the Rad/Nuc Med Patient file.
139 ; Only the "AO" cross-reference will be deleted. Data
140 ; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
141 ; Orders file will remain intact.
142 ;
143 ; Hmm, how do we know if we've done this in the past???
144 ;
145 N RA1,RACNI,RADFN,RADTI,RAORD,RATXT S RATXT(1)=" "
146 S RAORD=+$$PARCP^XPDUTL("PST35")
147 S RATXT(2)="Delete corrupted ""AO"" cross-reference data from the"
148 S RATXT(3)="Rad/Nuc Med Patient file. Only the ""AO"" cross-reference"
149 S RATXT(4)="will be deleted. Data in the Rad/Nuc Med Patient file"
150 S RATXT(5)="and the Rad/Nuc Med Orders file will remain intact."
151 D MES^XPDUTL(.RATXT)
152 F S RAORD=$O(^RADPT("AO",RAORD)) Q:RAORD'>0 D
153 . S RADFN=0
154 . F S RADFN=$O(^RADPT("AO",RAORD,RADFN)) Q:RADFN'>0 D
155 .. S RADTI=0
156 .. F S RADTI=$O(^RADPT("AO",RAORD,RADFN,RADTI)) Q:RADTI'>0 D
157 ... S RACNI=0
158 ... F S RACNI=$O(^RADPT("AO",RAORD,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
159 .... K:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ^RADPT("AO",RAORD,RADFN,RADTI,RACNI) ; if an exam is deleted, the "AO" xref for that exam should also be deleted
160 .... K:'$D(^RAO(75.1,"B",RADFN,RAORD)) ^RADPT("AO",RAORD,RADFN) ; if an order is deleted, the "AO" xref for that order should also be deleted
161 .... Q
162 ... Q
163 .. Q
164 . S RA1=+$$UPCP^XPDUTL("PST35",RAORD)
165 . Q
166 Q
Note: See TracBrowser for help on using the repository browser.