RAIPST3 ;HIRMFO/GJC - Clean-up of the v5.0 environment ;10/9/97 14:40
VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
S ZTREQ="@" ; delete from the task global
I +$G(DIFROM)'=+$P($T(VERSION),";",3) S XPDABORT=2 Q
N RAIPST
;
S RAIPST=$$NEWCP^XPDUTL("PST31","NUMLIN^RAIPST3")
; This subroutine will delete the Number Of Lines field (12)
; and all associated data from the Rad/Nuc Med Reports file (74)
;
S RAIPST=$$NEWCP^XPDUTL("PST32","TCOMNTS^RAIPST3")
; This subroutine will delete the Transfer Comment field (150)
; and all associated data from the Examinations Sub-Field
; (70.03)
;
S RAIPST=$$NEWCP^XPDUTL("PST33","DISTQ^RAIPST3")
; This subroutine will delete the following fields from the
; Report Distribution (74.4) file: Hospital Division (5)
; Imaging Location (7), Patient (9) and SSN (10). All data
; associated with these fields will be deleted.
;
S RAIPST=$$NEWCP^XPDUTL("PST34","TIMOUT^RAIPST3")
; This subroutine will delete the '*Timeout After How
; Many Second' field from the Imaging Type (79.2) file.
; All data associated with this field will be deleted.
;
S RAIPST=$$NEWCP^XPDUTL("PST35","AOXREF^RAIPST3")
; This subroutine will delete corrupted "AO" cross-
; reference data from the Rad/Nuc Med Patient file.
; Only the "AO" cross-reference will be deleted. Data
; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
; Orders file will remain intact.
;
NUMLIN ; This subroutine will delete the Number Of Lines field (12)
; and all associated data in the Rad/Nuc Med Reports file (74)
Q:'($D(^DD(74,12,0))#2) ; Done in the past
N %,DA,DIC,DIK,RA1,RACNT,RAD0,RALNUM,RATXT,X,Y
S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST31")
S RATXT(2)="Deleting obsolete NUMBER OF LINES field from Rad/Nuc Med"
S RATXT(3)="Reports data dictionary. Deleting Number of Lines data"
S RATXT(4)="from the Rad/Nuc Med Reports file. Please be patient,"
S RATXT(5)="this may take awhile." D BMES^XPDUTL(.RATXT)
F S RAD0=$O(^RARPT(RAD0)) Q:RAD0'>0 D
. S RALNUM=$P($G(^RARPT(RAD0,"T")),"^",2)
. D:RALNUM]"" ENKILL^RAXREF(74,12,RALNUM,.RAD0)
. S:RALNUM]"" $P(^RARPT(RAD0,"T"),"^",2)=""
. S RACNT=+$G(RACNT)+1
. W:'(RACNT#500)&('$D(ZTQUEUED)) "."
. S RA1=+$$UPCP^XPDUTL("PST31",RAD0)
. Q
S DIK="^DD(74,",DA(1)=74,DA=12 D ^DIK ; delete from data dictionary
Q
TCOMNTS ; This subroutine will delete the Transfer Comment field (150)
; and all associated data from the Examinations Sub-Field (70.03)
Q:'($D(^DD(70.03,150,0))#2) ; Done in the past
N %,DA,DIC,DIK,RA1,RACNI,RACNT,RADA,RADFN,RADTI,RATCOM,RATXT,X,Y
S RATXT(1)=" ",RADFN=+$$PARCP^XPDUTL("PST32")
S RATXT(2)="Deleting obsolete TRANSFER COMMENT field from Examinations sub-file"
S RATXT(3)="data dictionary. Deleting the Transfer Comment data from the Rad/Nuc"
S RATXT(4)="Med Patient file. Please be patient, this may take awhile."
D BMES^XPDUTL(.RATXT)
F S RADFN=$O(^RADPT(RADFN)) Q:RADFN'>0 D
. S RADTI=0 F S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 D
.. S RACNI=0
.. F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D
... S RATCOM=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")),"^")
... I RATCOM]"" D
.... S RADA(2)=RADFN,RADA(1)=RADTI,RADA=RACNI
.... D ENKILL^RAXREF(70.03,150,RATCOM,.RADA)
.... Q
... K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")
... Q
.. Q
. S RACNT=+$G(RACNT)+1
. W:'(RACNT#500)&('$D(ZTQUEUED)) "."
. S RA1=+$$UPCP^XPDUTL("PST32",RADFN)
. Q
S DIK="^DD(70.03,",DA(1)=70.03,DA=150
D ^DIK ; delete the data dictionary
Q
DISTQ ; This subroutine will delete the following fields from the
; Report Distribution (74.4) file: Hospital Division (5)
; Imaging Location (7), Patient (9) and SSN (10). All data
; associated with these fields will be deleted.
Q:'($D(^DD(74.4,10,0))#2) ; Done in the past, this is the last field
; deleted.
N %,DA,DIC,DIK,RA1,RA744,RACNT,RAD0,RAHD,RAIL,RAPAT,RASSN,RATXT,X,Y
S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST33")
S RATXT(2)="Deleting the following obsolete fields and data from the"
S RATXT(3)="Report Distribution data dictionary:"
S RATXT(4)="HOSPITAL DIVISION, IMAGING LOCATION, PATIENT and SSN."
D BMES^XPDUTL(.RATXT)
F S RAD0=$O(^RABTCH(74.4,RAD0)) Q:RAD0'>0 D
. S RA744=$G(^RABTCH(74.4,RAD0,0)),RAHD=$P(RA744,"^",5)
. S RAIL=$P(RA744,"^",7),RAPAT=$P(RA744,"^",9),RASSN=$P(RA744,"^",10)
. I RAHD]"" D
.. D ENKILL^RAXREF(74.4,5,RAHD,.RAD0)
.. S $P(^RABTCH(74.4,RAD0,0),"^",5)=""
.. Q
. I RAIL]"" D
.. D ENKILL^RAXREF(74.4,7,RAIL,.RAD0)
.. S $P(^RABTCH(74.4,RAD0,0),"^",7)=""
.. Q
. I RAPAT]"" D
.. D ENKILL^RAXREF(74.4,9,RAPAT,.RAD0)
.. S $P(^RABTCH(74.4,RAD0,0),"^",9)=""
.. Q
. I RASSN]"" D
.. D ENKILL^RAXREF(74.4,10,RASSN,.RAD0)
.. S $P(^RABTCH(74.4,RAD0,0),"^",10)=""
.. Q
. S RACNT=+$G(RACNT)+1
. W:'(RACNT#500)&('$D(ZTQUEUED)) "."
. S RA1=+$$UPCP^XPDUTL("PST33",RAD0)
. Q
; delete the fields one at a time.
S DIK="^DD(74.4,",DA(1)=74.4,DA=5 D ^DIK K %,DA,DIC,DIK
S DIK="^DD(74.4,",DA(1)=74.4,DA=7 D ^DIK K %,DA,DIC,DIK
S DIK="^DD(74.4,",DA(1)=74.4,DA=9 D ^DIK K %,DA,DIC,DIK
S DIK="^DD(74.4,",DA(1)=74.4,DA=10 D ^DIK K %,DA,DIC,DIK
Q
TIMOUT ; This subroutine will delete the '*Timeout After How
; Many Second' field from the Imaging Type (79.2) file.
; All data associated with this field will be deleted.
Q:'($D(^DD(79.2,2,0))#2) ; Done in the past
N %,DA,DIC,DIK,RAD0,RASEC,RATXT,X,Y S RATXT(1)=" "
S RATXT(2)="Deleting obsolete *TIMEOUT AFTER HOW MANY SECOND field and data from"
S RATXT(3)="the Imaging Type file."
D MES^XPDUTL(.RATXT) S RAD0=0
F S RAD0=$O(^RA(79.2,RAD0)) Q:RAD0'>0 D
. S RASEC=$P($G(^RA(79.2,RAD0,0)),"^",2)
. D:RASEC]"" ENKILL^RAXREF(79.2,2,RASEC,.RAD0)
. S:RASEC]"" $P(^RA(79.2,RAD0,0),"^",2)=""
. Q
S DIK="^DD(79.2,",DA(1)=79.2,DA=2 D ^DIK K %,DA,DIC,DIK ; remove field
Q
AOXREF ; This subroutine will delete corrupted "AO" cross-
; reference data from the Rad/Nuc Med Patient file.
; Only the "AO" cross-reference will be deleted. Data
; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
; Orders file will remain intact.
;
; Hmm, how do we know if we've done this in the past???
;
N RA1,RACNI,RADFN,RADTI,RAORD,RATXT S RATXT(1)=" "
S RAORD=+$$PARCP^XPDUTL("PST35")
S RATXT(2)="Delete corrupted ""AO"" cross-reference data from the"
S RATXT(3)="Rad/Nuc Med Patient file. Only the ""AO"" cross-reference"
S RATXT(4)="will be deleted. Data in the Rad/Nuc Med Patient file"
S RATXT(5)="and the Rad/Nuc Med Orders file will remain intact."
D MES^XPDUTL(.RATXT)
F S RAORD=$O(^RADPT("AO",RAORD)) Q:RAORD'>0 D
. S RADFN=0
. F S RADFN=$O(^RADPT("AO",RAORD,RADFN)) Q:RADFN'>0 D
.. S RADTI=0
.. F S RADTI=$O(^RADPT("AO",RAORD,RADFN,RADTI)) Q:RADTI'>0 D
... S RACNI=0
... F S RACNI=$O(^RADPT("AO",RAORD,RADFN,RADTI,RACNI)) Q:RACNI'>0 D
.... 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
.... 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
.... Q
... Q
.. Q
. S RA1=+$$UPCP^XPDUTL("PST35",RAORD)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAIPST3 7426 printed Dec 13, 2024@02:36:30 Page 2
RAIPST3 ;HIRMFO/GJC - Clean-up of the v5.0 environment ;10/9/97 14:40
VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+1 ; delete from the task global
SET ZTREQ="@"
+2 IF +$GET(DIFROM)'=+$PIECE($TEXT(VERSION),";",3)
SET XPDABORT=2
QUIT
+3 NEW RAIPST
+4 ;
+5 SET RAIPST=$$NEWCP^XPDUTL("PST31","NUMLIN^RAIPST3")
+6 ; This subroutine will delete the Number Of Lines field (12)
+7 ; and all associated data from the Rad/Nuc Med Reports file (74)
+8 ;
+9 SET RAIPST=$$NEWCP^XPDUTL("PST32","TCOMNTS^RAIPST3")
+10 ; This subroutine will delete the Transfer Comment field (150)
+11 ; and all associated data from the Examinations Sub-Field
+12 ; (70.03)
+13 ;
+14 SET RAIPST=$$NEWCP^XPDUTL("PST33","DISTQ^RAIPST3")
+15 ; This subroutine will delete the following fields from the
+16 ; Report Distribution (74.4) file: Hospital Division (5)
+17 ; Imaging Location (7), Patient (9) and SSN (10). All data
+18 ; associated with these fields will be deleted.
+19 ;
+20 SET RAIPST=$$NEWCP^XPDUTL("PST34","TIMOUT^RAIPST3")
+21 ; This subroutine will delete the '*Timeout After How
+22 ; Many Second' field from the Imaging Type (79.2) file.
+23 ; All data associated with this field will be deleted.
+24 ;
+25 SET RAIPST=$$NEWCP^XPDUTL("PST35","AOXREF^RAIPST3")
+26 ; This subroutine will delete corrupted "AO" cross-
+27 ; reference data from the Rad/Nuc Med Patient file.
+28 ; Only the "AO" cross-reference will be deleted. Data
+29 ; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
+30 ; Orders file will remain intact.
+31 ;
NUMLIN ; This subroutine will delete the Number Of Lines field (12)
+1 ; and all associated data in the Rad/Nuc Med Reports file (74)
+2 ; Done in the past
if '($DATA(^DD(74,12,0))#2)
QUIT
+3 NEW %,DA,DIC,DIK,RA1,RACNT,RAD0,RALNUM,RATXT,X,Y
+4 SET RATXT(1)=" "
SET RAD0=+$$PARCP^XPDUTL("PST31")
+5 SET RATXT(2)="Deleting obsolete NUMBER OF LINES field from Rad/Nuc Med"
+6 SET RATXT(3)="Reports data dictionary. Deleting Number of Lines data"
+7 SET RATXT(4)="from the Rad/Nuc Med Reports file. Please be patient,"
+8 SET RATXT(5)="this may take awhile."
DO BMES^XPDUTL(.RATXT)
+9 FOR
SET RAD0=$ORDER(^RARPT(RAD0))
if RAD0'>0
QUIT
Begin DoDot:1
+10 SET RALNUM=$PIECE($GET(^RARPT(RAD0,"T")),"^",2)
+11 if RALNUM]""
DO ENKILL^RAXREF(74,12,RALNUM,.RAD0)
+12 if RALNUM]""
SET $PIECE(^RARPT(RAD0,"T"),"^",2)=""
+13 SET RACNT=+$GET(RACNT)+1
+14 if '(RACNT#500)&('$DATA(ZTQUEUED))
WRITE "."
+15 SET RA1=+$$UPCP^XPDUTL("PST31",RAD0)
+16 QUIT
End DoDot:1
+17 ; delete from data dictionary
SET DIK="^DD(74,"
SET DA(1)=74
SET DA=12
DO ^DIK
+18 QUIT
TCOMNTS ; This subroutine will delete the Transfer Comment field (150)
+1 ; and all associated data from the Examinations Sub-Field (70.03)
+2 ; Done in the past
if '($DATA(^DD(70.03,150,0))#2)
QUIT
+3 NEW %,DA,DIC,DIK,RA1,RACNI,RACNT,RADA,RADFN,RADTI,RATCOM,RATXT,X,Y
+4 SET RATXT(1)=" "
SET RADFN=+$$PARCP^XPDUTL("PST32")
+5 SET RATXT(2)="Deleting obsolete TRANSFER COMMENT field from Examinations sub-file"
+6 SET RATXT(3)="data dictionary. Deleting the Transfer Comment data from the Rad/Nuc"
+7 SET RATXT(4)="Med Patient file. Please be patient, this may take awhile."
+8 DO BMES^XPDUTL(.RATXT)
+9 FOR
SET RADFN=$ORDER(^RADPT(RADFN))
if RADFN'>0
QUIT
Begin DoDot:1
+10 SET RADTI=0
FOR
SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))
if RADTI'>0
QUIT
Begin DoDot:2
+11 SET RACNI=0
+12 FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if RACNI'>0
QUIT
Begin DoDot:3
+13 SET RATCOM=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")),"^")
+14 IF RATCOM]""
Begin DoDot:4
+15 SET RADA(2)=RADFN
SET RADA(1)=RADTI
SET RADA=RACNI
+16 DO ENKILL^RAXREF(70.03,150,RATCOM,.RADA)
+17 QUIT
End DoDot:4
+18 KILL ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 SET RACNT=+$GET(RACNT)+1
+22 if '(RACNT#500)&('$DATA(ZTQUEUED))
WRITE "."
+23 SET RA1=+$$UPCP^XPDUTL("PST32",RADFN)
+24 QUIT
End DoDot:1
+25 SET DIK="^DD(70.03,"
SET DA(1)=70.03
SET DA=150
+26 ; delete the data dictionary
DO ^DIK
+27 QUIT
DISTQ ; This subroutine will delete the following fields from the
+1 ; Report Distribution (74.4) file: Hospital Division (5)
+2 ; Imaging Location (7), Patient (9) and SSN (10). All data
+3 ; associated with these fields will be deleted.
+4 ; Done in the past, this is the last field
if '($DATA(^DD(74.4,10,0))#2)
QUIT
+5 ; deleted.
+6 NEW %,DA,DIC,DIK,RA1,RA744,RACNT,RAD0,RAHD,RAIL,RAPAT,RASSN,RATXT,X,Y
+7 SET RATXT(1)=" "
SET RAD0=+$$PARCP^XPDUTL("PST33")
+8 SET RATXT(2)="Deleting the following obsolete fields and data from the"
+9 SET RATXT(3)="Report Distribution data dictionary:"
+10 SET RATXT(4)="HOSPITAL DIVISION, IMAGING LOCATION, PATIENT and SSN."
+11 DO BMES^XPDUTL(.RATXT)
+12 FOR
SET RAD0=$ORDER(^RABTCH(74.4,RAD0))
if RAD0'>0
QUIT
Begin DoDot:1
+13 SET RA744=$GET(^RABTCH(74.4,RAD0,0))
SET RAHD=$PIECE(RA744,"^",5)
+14 SET RAIL=$PIECE(RA744,"^",7)
SET RAPAT=$PIECE(RA744,"^",9)
SET RASSN=$PIECE(RA744,"^",10)
+15 IF RAHD]""
Begin DoDot:2
+16 DO ENKILL^RAXREF(74.4,5,RAHD,.RAD0)
+17 SET $PIECE(^RABTCH(74.4,RAD0,0),"^",5)=""
+18 QUIT
End DoDot:2
+19 IF RAIL]""
Begin DoDot:2
+20 DO ENKILL^RAXREF(74.4,7,RAIL,.RAD0)
+21 SET $PIECE(^RABTCH(74.4,RAD0,0),"^",7)=""
+22 QUIT
End DoDot:2
+23 IF RAPAT]""
Begin DoDot:2
+24 DO ENKILL^RAXREF(74.4,9,RAPAT,.RAD0)
+25 SET $PIECE(^RABTCH(74.4,RAD0,0),"^",9)=""
+26 QUIT
End DoDot:2
+27 IF RASSN]""
Begin DoDot:2
+28 DO ENKILL^RAXREF(74.4,10,RASSN,.RAD0)
+29 SET $PIECE(^RABTCH(74.4,RAD0,0),"^",10)=""
+30 QUIT
End DoDot:2
+31 SET RACNT=+$GET(RACNT)+1
+32 if '(RACNT#500)&('$DATA(ZTQUEUED))
WRITE "."
+33 SET RA1=+$$UPCP^XPDUTL("PST33",RAD0)
+34 QUIT
End DoDot:1
+35 ; delete the fields one at a time.
+36 SET DIK="^DD(74.4,"
SET DA(1)=74.4
SET DA=5
DO ^DIK
KILL %,DA,DIC,DIK
+37 SET DIK="^DD(74.4,"
SET DA(1)=74.4
SET DA=7
DO ^DIK
KILL %,DA,DIC,DIK
+38 SET DIK="^DD(74.4,"
SET DA(1)=74.4
SET DA=9
DO ^DIK
KILL %,DA,DIC,DIK
+39 SET DIK="^DD(74.4,"
SET DA(1)=74.4
SET DA=10
DO ^DIK
KILL %,DA,DIC,DIK
+40 QUIT
TIMOUT ; This subroutine will delete the '*Timeout After How
+1 ; Many Second' field from the Imaging Type (79.2) file.
+2 ; All data associated with this field will be deleted.
+3 ; Done in the past
if '($DATA(^DD(79.2,2,0))#2)
QUIT
+4 NEW %,DA,DIC,DIK,RAD0,RASEC,RATXT,X,Y
SET RATXT(1)=" "
+5 SET RATXT(2)="Deleting obsolete *TIMEOUT AFTER HOW MANY SECOND field and data from"
+6 SET RATXT(3)="the Imaging Type file."
+7 DO MES^XPDUTL(.RATXT)
SET RAD0=0
+8 FOR
SET RAD0=$ORDER(^RA(79.2,RAD0))
if RAD0'>0
QUIT
Begin DoDot:1
+9 SET RASEC=$PIECE($GET(^RA(79.2,RAD0,0)),"^",2)
+10 if RASEC]""
DO ENKILL^RAXREF(79.2,2,RASEC,.RAD0)
+11 if RASEC]""
SET $PIECE(^RA(79.2,RAD0,0),"^",2)=""
+12 QUIT
End DoDot:1
+13 ; remove field
SET DIK="^DD(79.2,"
SET DA(1)=79.2
SET DA=2
DO ^DIK
KILL %,DA,DIC,DIK
+14 QUIT
AOXREF ; This subroutine will delete corrupted "AO" cross-
+1 ; reference data from the Rad/Nuc Med Patient file.
+2 ; Only the "AO" cross-reference will be deleted. Data
+3 ; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
+4 ; Orders file will remain intact.
+5 ;
+6 ; Hmm, how do we know if we've done this in the past???
+7 ;
+8 NEW RA1,RACNI,RADFN,RADTI,RAORD,RATXT
SET RATXT(1)=" "
+9 SET RAORD=+$$PARCP^XPDUTL("PST35")
+10 SET RATXT(2)="Delete corrupted ""AO"" cross-reference data from the"
+11 SET RATXT(3)="Rad/Nuc Med Patient file. Only the ""AO"" cross-reference"
+12 SET RATXT(4)="will be deleted. Data in the Rad/Nuc Med Patient file"
+13 SET RATXT(5)="and the Rad/Nuc Med Orders file will remain intact."
+14 DO MES^XPDUTL(.RATXT)
+15 FOR
SET RAORD=$ORDER(^RADPT("AO",RAORD))
if RAORD'>0
QUIT
Begin DoDot:1
+16 SET RADFN=0
+17 FOR
SET RADFN=$ORDER(^RADPT("AO",RAORD,RADFN))
if RADFN'>0
QUIT
Begin DoDot:2
+18 SET RADTI=0
+19 FOR
SET RADTI=$ORDER(^RADPT("AO",RAORD,RADFN,RADTI))
if RADTI'>0
QUIT
Begin DoDot:3
+20 SET RACNI=0
+21 FOR
SET RACNI=$ORDER(^RADPT("AO",RAORD,RADFN,RADTI,RACNI))
if RACNI'>0
QUIT
Begin DoDot:4
+22 ; if an exam is deleted, the "AO" xref for that exam should also be deleted
if '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
KILL ^RADPT("AO",RAORD,RADFN,RADTI,RACNI)
+23 ; if an order is deleted, the "AO" xref for that order should also be deleted
if '$DATA(^RAO(75.1,"B",RADFN,RAORD))
KILL ^RADPT("AO",RAORD,RADFN)
+24 QUIT
End DoDot:4
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
+27 SET RA1=+$$UPCP^XPDUTL("PST35",RAORD)
+28 QUIT
End DoDot:1
+29 QUIT
