Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAIPST3

RAIPST3.m

Go to the documentation of this file. 
  1. RAIPST3 ;HIRMFO/GJC - Clean-up of the v5.0 environment ;10/9/97  14:40
  1. VERSION ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1.  S ZTREQ="@" ; delete from the task global
  1.  I +$G(DIFROM)'=+$P($T(VERSION),";",3) S XPDABORT=2 Q
  1.  N RAIPST
  1.  ;
  1.  S RAIPST=$$NEWCP^XPDUTL("PST31","NUMLIN^RAIPST3")
  1.  ;        This subroutine will delete the Number Of Lines field (12)
  1.  ;        and all associated data from the Rad/Nuc Med Reports file (74)
  1.  ;
  1.  S RAIPST=$$NEWCP^XPDUTL("PST32","TCOMNTS^RAIPST3")
  1.  ;        This subroutine will delete the Transfer Comment field (150)
  1.  ;        and all associated data from the Examinations Sub-Field
  1.  ;        (70.03)
  1.  ;
  1.  S RAIPST=$$NEWCP^XPDUTL("PST33","DISTQ^RAIPST3")
  1.  ;        This subroutine will delete the following fields from the
  1.  ;        Report Distribution (74.4) file: Hospital Division (5)
  1.  ;        Imaging Location (7), Patient (9) and SSN (10).  All data
  1.  ;        associated with these fields will be deleted.
  1.  ;
  1.  S RAIPST=$$NEWCP^XPDUTL("PST34","TIMOUT^RAIPST3")
  1.  ;        This subroutine will delete the '*Timeout After How
  1.  ;        Many Second' field from the Imaging Type (79.2) file.
  1.  ;        All data associated with this field will be deleted.
  1.  ;
  1.  S RAIPST=$$NEWCP^XPDUTL("PST35","AOXREF^RAIPST3")
  1.  ;        This subroutine will delete corrupted "AO" cross-
  1.  ;        reference data from the Rad/Nuc Med Patient file.
  1.  ;        Only the "AO" cross-reference will be deleted.  Data
  1.  ;        in the Rad/Nuc Med Patient file and the Rad/Nuc Med
  1.  ;        Orders file will remain intact.
  1.  ;
  1. NUMLIN ; This subroutine will delete the Number Of Lines field (12)
  1.  ; and all associated data in the Rad/Nuc Med Reports file (74)
  1.  Q:'($D(^DD(74,12,0))#2)  ; Done in the past
  1.  N %,DA,DIC,DIK,RA1,RACNT,RAD0,RALNUM,RATXT,X,Y
  1.  S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST31")
  1.  S RATXT(2)="Deleting obsolete NUMBER OF LINES field from Rad/Nuc Med"
  1.  S RATXT(3)="Reports data dictionary.  Deleting Number of Lines data"
  1.  S RATXT(4)="from the Rad/Nuc Med Reports file.  Please be patient,"
  1.  S RATXT(5)="this may take awhile." D BMES^XPDUTL(.RATXT)
  1.  F  S RAD0=$O(^RARPT(RAD0)) Q:RAD0'>0  D
  1.  . S RALNUM=$P($G(^RARPT(RAD0,"T")),"^",2)
  1.  . D:RALNUM]"" ENKILL^RAXREF(74,12,RALNUM,.RAD0)
  1.  . S:RALNUM]"" $P(^RARPT(RAD0,"T"),"^",2)=""
  1.  . S RACNT=+$G(RACNT)+1
  1.  . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
  1.  . S RA1=+$$UPCP^XPDUTL("PST31",RAD0)
  1.  . Q
  1.  S DIK="^DD(74,",DA(1)=74,DA=12 D ^DIK ; delete from data dictionary
  1.  Q
  1. TCOMNTS ; This subroutine will delete the Transfer Comment field (150)
  1.  ; and all associated data from the Examinations Sub-Field (70.03)
  1.  Q:'($D(^DD(70.03,150,0))#2)  ; Done in the past
  1.  N %,DA,DIC,DIK,RA1,RACNI,RACNT,RADA,RADFN,RADTI,RATCOM,RATXT,X,Y
  1.  S RATXT(1)=" ",RADFN=+$$PARCP^XPDUTL("PST32")
  1.  S RATXT(2)="Deleting obsolete TRANSFER COMMENT field from Examinations sub-file"
  1.  S RATXT(3)="data dictionary.  Deleting the Transfer Comment data from the Rad/Nuc"
  1.  S RATXT(4)="Med Patient file.  Please be patient, this may take awhile."
  1.  D BMES^XPDUTL(.RATXT)
  1.  F  S RADFN=$O(^RADPT(RADFN)) Q:RADFN'>0  D
  1.  . S RADTI=0 F  S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0  D
  1.  .. S RACNI=0
  1.  .. F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0  D
  1.  ... S RATCOM=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")),"^")
  1.  ... I RATCOM]"" D
  1.  .... S RADA(2)=RADFN,RADA(1)=RADTI,RADA=RACNI
  1.  .... D ENKILL^RAXREF(70.03,150,RATCOM,.RADA)
  1.  .... Q
  1.  ... K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TFR")
  1.  ... Q
  1.  .. Q
  1.  . S RACNT=+$G(RACNT)+1
  1.  . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
  1.  . S RA1=+$$UPCP^XPDUTL("PST32",RADFN)
  1.  . Q
  1.  S DIK="^DD(70.03,",DA(1)=70.03,DA=150
  1.  D ^DIK ; delete the data dictionary
  1.  Q
  1. DISTQ ; This subroutine will delete the following fields from the
  1.  ; Report Distribution (74.4) file: Hospital Division (5)
  1.  ; Imaging Location (7), Patient (9) and SSN (10).  All data
  1.  ; associated with these fields will be deleted.
  1.  Q:'($D(^DD(74.4,10,0))#2)  ; Done in the past, this is the last field
  1.  ; deleted.
  1.  N %,DA,DIC,DIK,RA1,RA744,RACNT,RAD0,RAHD,RAIL,RAPAT,RASSN,RATXT,X,Y
  1.  S RATXT(1)=" ",RAD0=+$$PARCP^XPDUTL("PST33")
  1.  S RATXT(2)="Deleting the following obsolete fields and data from the"
  1.  S RATXT(3)="Report Distribution data dictionary:"
  1.  S RATXT(4)="HOSPITAL DIVISION, IMAGING LOCATION, PATIENT and SSN."
  1.  D BMES^XPDUTL(.RATXT)
  1.  F  S RAD0=$O(^RABTCH(74.4,RAD0)) Q:RAD0'>0  D
  1.  . S RA744=$G(^RABTCH(74.4,RAD0,0)),RAHD=$P(RA744,"^",5)
  1.  . S RAIL=$P(RA744,"^",7),RAPAT=$P(RA744,"^",9),RASSN=$P(RA744,"^",10)
  1.  . I RAHD]"" D
  1.  .. D ENKILL^RAXREF(74.4,5,RAHD,.RAD0)
  1.  .. S $P(^RABTCH(74.4,RAD0,0),"^",5)=""
  1.  .. Q
  1.  . I RAIL]"" D
  1.  .. D ENKILL^RAXREF(74.4,7,RAIL,.RAD0)
  1.  .. S $P(^RABTCH(74.4,RAD0,0),"^",7)=""
  1.  .. Q
  1.  . I RAPAT]"" D
  1.  .. D ENKILL^RAXREF(74.4,9,RAPAT,.RAD0)
  1.  .. S $P(^RABTCH(74.4,RAD0,0),"^",9)=""
  1.  .. Q
  1.  . I RASSN]"" D
  1.  .. D ENKILL^RAXREF(74.4,10,RASSN,.RAD0)
  1.  .. S $P(^RABTCH(74.4,RAD0,0),"^",10)=""
  1.  .. Q
  1.  . S RACNT=+$G(RACNT)+1
  1.  . W:'(RACNT#500)&('$D(ZTQUEUED)) "."
  1.  . S RA1=+$$UPCP^XPDUTL("PST33",RAD0)
  1.  . Q
  1.  ; delete the fields one at a time.
  1.  S DIK="^DD(74.4,",DA(1)=74.4,DA=5 D ^DIK K %,DA,DIC,DIK
  1.  S DIK="^DD(74.4,",DA(1)=74.4,DA=7 D ^DIK K %,DA,DIC,DIK
  1.  S DIK="^DD(74.4,",DA(1)=74.4,DA=9 D ^DIK K %,DA,DIC,DIK
  1.  S DIK="^DD(74.4,",DA(1)=74.4,DA=10 D ^DIK K %,DA,DIC,DIK
  1.  Q
  1. TIMOUT ; This subroutine will delete the '*Timeout After How
  1.  ; Many Second' field from the Imaging Type (79.2) file.
  1.  ; All data associated with this field will be deleted.
  1.  Q:'($D(^DD(79.2,2,0))#2)  ; Done in the past
  1.  N %,DA,DIC,DIK,RAD0,RASEC,RATXT,X,Y S RATXT(1)=" "
  1.  S RATXT(2)="Deleting obsolete *TIMEOUT AFTER HOW MANY SECOND field and data from"
  1.  S RATXT(3)="the Imaging Type file."
  1.  D MES^XPDUTL(.RATXT) S RAD0=0
  1.  F  S RAD0=$O(^RA(79.2,RAD0)) Q:RAD0'>0  D
  1.  . S RASEC=$P($G(^RA(79.2,RAD0,0)),"^",2)
  1.  . D:RASEC]"" ENKILL^RAXREF(79.2,2,RASEC,.RAD0)
  1.  . S:RASEC]"" $P(^RA(79.2,RAD0,0),"^",2)=""
  1.  . Q
  1.  S DIK="^DD(79.2,",DA(1)=79.2,DA=2 D ^DIK K %,DA,DIC,DIK ; remove field
  1.  Q
  1. AOXREF ; This subroutine will delete corrupted "AO" cross-
  1.  ; reference data from the Rad/Nuc Med Patient file.
  1.  ; Only the "AO" cross-reference will be deleted.  Data
  1.  ; in the Rad/Nuc Med Patient file and the Rad/Nuc Med
  1.  ; Orders file will remain intact.
  1.  ;
  1.  ; Hmm, how do we know if we've done this in the past???
  1.  ;
  1.  N RA1,RACNI,RADFN,RADTI,RAORD,RATXT S RATXT(1)=" "
  1.  S RAORD=+$$PARCP^XPDUTL("PST35")
  1.  S RATXT(2)="Delete corrupted ""AO"" cross-reference data from the"
  1.  S RATXT(3)="Rad/Nuc Med Patient file.  Only the ""AO"" cross-reference"
  1.  S RATXT(4)="will be deleted.  Data in the Rad/Nuc Med Patient file"
  1.  S RATXT(5)="and the Rad/Nuc Med Orders file will remain intact."
  1.  D MES^XPDUTL(.RATXT)
  1.  F  S RAORD=$O(^RADPT("AO",RAORD)) Q:RAORD'>0  D
  1.  . S RADFN=0
  1.  . F  S RADFN=$O(^RADPT("AO",RAORD,RADFN)) Q:RADFN'>0  D
  1.  .. S RADTI=0
  1.  .. F  S RADTI=$O(^RADPT("AO",RAORD,RADFN,RADTI)) Q:RADTI'>0  D
  1.  ... S RACNI=0
  1.  ... F  S RACNI=$O(^RADPT("AO",RAORD,RADFN,RADTI,RACNI)) Q:RACNI'>0  D
  1.  .... 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
  1.  .... 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
  1.  .... Q
  1.  ... Q
  1.  .. Q
  1.  . S RA1=+$$UPCP^XPDUTL("PST35",RAORD)
  1.  . Q
  1.  Q