RAPURGE ;HISC/CAH - AISC/MJK - Schedule Data Purge ;4/17/03 08:45
;;5.0;Radiology/Nuclear Medicine;**34,41**;Mar 16, 1998
SCH ;Edit purge parameters and schedule Rad/Nuc Med data purge
I '($D(DUZ)#2) W !!,$C(7),"No 'DUZ' code. Purging not allowed.",! Q
I '$D(^VA(200,DUZ,0)) W !!,$C(7),"Not a valid 'DUZ' code. Purging not allowed.",! Q
F I=1:1:15 W !?9,$P($T(REMIND+I),";;",2)
S DIR(0)="Y",DIR("B")="Yes",DIR("?")="Enter 'YES' or 'RETURN' to edit purge parameters, or 'NO' not to.",DIR("A")="Do you want to edit the Imaging Type purge parameters" D ^DIR K DIR G QB:$D(DIRUT),PURGE:'Y
EDIT W !! S DIC="^RA(79.2,",DIC(0)="AEQM",DIC("A")="Select IMAGING TYPE: " D ^DIC K DIC I Y>0 S DA=+Y,DIE="^RA(79.2,",DIE("NO^")="",DR="[RA ON-LINE CRITERIA]" D ^DIE K DE,DQ,DIC,DIE,DR G EDIT
PURGE W ! S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you wish to schedule the data purge",DIR("?")="Enter 'YES' to schedule the data purge, or 'NO' not to."
D ^DIR K DIR I $D(DIRUT)!(Y=0) G QB
D RECORD
; Display entries from 79.2 for selection
N I,J,CNT,RAX S (I,J,CNT)=0 K RAPUR
W !!?12,"IMAGING TYPES",!?12,"-------------",!
; RAX(sequential no.)=ien file 79.2
F S I=$O(^RA(79.2,"B",I)) Q:I="" F S J=$O(^RA(79.2,"B",I,J)) Q:'J S CNT=CNT+1 W !?3,CNT,") ",I S RAX(CNT)=J
W ! S DIR(0)="L^1:"_CNT,DIR("A")="Select Imaging Type(s) to Purge",DIR("?")="Select by number, one or more imaging types to be purged" D ^DIR K DIR I $D(DIRUT) G QB
; RAPUR(ien file 79.2)=""
S I="" F J=1:1 S I=$P(Y,",",J) Q:'I S RAPUR(RAX(I))=""
W ! S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you wish to re-purge records that have been purged in the past",DIR("?")="Enter 'YES' to re-purge records purged in the past, or 'NO' not to."
D ^DIR K DIR G QB:$D(DIRUT) S RAREPURG=Y
D ASKF
G:'RAGO QB
K RAX S RAX="" F S RAX=$O(RAPUR(RAX)) Q:'RAX S DA=RAX,DIE="^RA(79.2,",DR="100///""NOW""",DR(2,79.23)="2///S;3////"_DUZ D ^DIE
K DA,DE,DIE,DQ,DR
S ZTRTN="START^RAPURGE1",ZTSAVE("RAPUR*")="",ZTSAVE("RAREPURG")="",ZTDESC="Rad/Nuc Med Data Purge" W ! D ZIS^RAUTL G Q:RAPOP
G START^RAPURGE1
QB W !,"--Nothing Done--"
Q K D0,D1,DA,DLAYGO,POP,RAPOP,RAPR,RAPUR,RAREPURG,X,Y,ZTDESC,ZTRTN,ZTSAVE,RAMES,RAGO,RAPURTYP Q
;
RECORD ; select which records to purge
S DIR(0)="S^E:Exams only;R:Reports only;B:Both exams & reports;"
S DIR("?")="Do you want to purge Exams, Reports, Exams & Reports ?"
S DIR("A")="Enter type of data to purge"
S DIR("B")="Reports only"
D ^DIR K DIR
S RAPURTYP=Y
Q
ASKF ;ask final question
S RAGO=0
W !!,"You have chosen to purge ",$S(RAPURTYP="E":"Exam",RAPURTYP="R":"Report",RAPURTYP="B":"Exam & Report",1:"?")," records from "
S I=""
F S I=$O(RAPUR(I)) Q:'I W " ",$P(^RA(79.2,I,0),U) W:$O(RAPUR(I)) ","
W !
S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you wish to proceed with the purge"
S DIR("?")="Enter 'YES' to go ahead with the purge, or 'NO' to exit from this option."
D ^DIR K DIR
S RAGO=Y
Q
REMIND ;
;;+--------------------------------------------------------+
;;| This option is used to remove data from one or all of |
;;| these globals: ^RADPT, ^RARPT |
;;| |
;;| Make sure IRM keeps the backup that was made prior to |
;;| running this option, and NOT overwrite that backup for |
;;| at least 6 months. Data from ^RADPT and ^RARPT can be |
;;| recovered. |
;;| |
;;| The cut-off dates for the 4 items (activity log, |
;;| report, clinical history, tracking time) are |
;;| compared to the exam date of those items. If the |
;;| exam date for an item is older than the cut-off date |
;;| for that item, then that item would be purged. |
;;+--------------------------------------------------------+
;;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPURGE 3910 printed Dec 13, 2024@02:39 Page 2
RAPURGE ;HISC/CAH - AISC/MJK - Schedule Data Purge ;4/17/03 08:45
+1 ;;5.0;Radiology/Nuclear Medicine;**34,41**;Mar 16, 1998
SCH ;Edit purge parameters and schedule Rad/Nuc Med data purge
+1 IF '($DATA(DUZ)#2)
WRITE !!,$CHAR(7),"No 'DUZ' code. Purging not allowed.",!
QUIT
+2 IF '$DATA(^VA(200,DUZ,0))
WRITE !!,$CHAR(7),"Not a valid 'DUZ' code. Purging not allowed.",!
QUIT
+3 FOR I=1:1:15
WRITE !?9,$PIECE($TEXT(REMIND+I),";;",2)
+4 SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("?")="Enter 'YES' or 'RETURN' to edit purge parameters, or 'NO' not to."
SET DIR("A")="Do you want to edit the Imaging Type purge parameters"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QB
if 'Y
GOTO PURGE
EDIT WRITE !!
SET DIC="^RA(79.2,"
SET DIC(0)="AEQM"
SET DIC("A")="Select IMAGING TYPE: "
DO ^DIC
KILL DIC
IF Y>0
SET DA=+Y
SET DIE="^RA(79.2,"
SET DIE("NO^")=""
SET DR="[RA ON-LINE CRITERIA]"
DO ^DIE
KILL DE,DQ,DIC,DIE,DR
GOTO EDIT
PURGE WRITE !
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you wish to schedule the data purge"
SET DIR("?")="Enter 'YES' to schedule the data purge, or 'NO' not to."
+1 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y=0)
GOTO QB
+2 DO RECORD
+3 ; Display entries from 79.2 for selection
+4 NEW I,J,CNT,RAX
SET (I,J,CNT)=0
KILL RAPUR
+5 WRITE !!?12,"IMAGING TYPES",!?12,"-------------",!
+6 ; RAX(sequential no.)=ien file 79.2
+7 FOR
SET I=$ORDER(^RA(79.2,"B",I))
if I=""
QUIT
FOR
SET J=$ORDER(^RA(79.2,"B",I,J))
if 'J
QUIT
SET CNT=CNT+1
WRITE !?3,CNT,") ",I
SET RAX(CNT)=J
+8 WRITE !
SET DIR(0)="L^1:"_CNT
SET DIR("A")="Select Imaging Type(s) to Purge"
SET DIR("?")="Select by number, one or more imaging types to be purged"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO QB
+9 ; RAPUR(ien file 79.2)=""
+10 SET I=""
FOR J=1:1
SET I=$PIECE(Y,",",J)
if 'I
QUIT
SET RAPUR(RAX(I))=""
+11 WRITE !
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you wish to re-purge records that have been purged in the past"
SET DIR("?")="Enter 'YES' to re-purge records purged in the past, or 'NO' not to."
+12 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QB
SET RAREPURG=Y
+13 DO ASKF
+14 if 'RAGO
GOTO QB
+15 KILL RAX
SET RAX=""
FOR
SET RAX=$ORDER(RAPUR(RAX))
if 'RAX
QUIT
SET DA=RAX
SET DIE="^RA(79.2,"
SET DR="100///""NOW"""
SET DR(2,79.23)="2///S;3////"_DUZ
DO ^DIE
+16 KILL DA,DE,DIE,DQ,DR
+17 SET ZTRTN="START^RAPURGE1"
SET ZTSAVE("RAPUR*")=""
SET ZTSAVE("RAREPURG")=""
SET ZTDESC="Rad/Nuc Med Data Purge"
WRITE !
DO ZIS^RAUTL
if RAPOP
GOTO Q
+18 GOTO START^RAPURGE1
QB WRITE !,"--Nothing Done--"
Q KILL D0,D1,DA,DLAYGO,POP,RAPOP,RAPR,RAPUR,RAREPURG,X,Y,ZTDESC,ZTRTN,ZTSAVE,RAMES,RAGO,RAPURTYP
QUIT
+1 ;
RECORD ; select which records to purge
+1 SET DIR(0)="S^E:Exams only;R:Reports only;B:Both exams & reports;"
+2 SET DIR("?")="Do you want to purge Exams, Reports, Exams & Reports ?"
+3 SET DIR("A")="Enter type of data to purge"
+4 SET DIR("B")="Reports only"
+5 DO ^DIR
KILL DIR
+6 SET RAPURTYP=Y
+7 QUIT
ASKF ;ask final question
+1 SET RAGO=0
+2 WRITE !!,"You have chosen to purge ",$SELECT(RAPURTYP="E":"Exam",RAPURTYP="R":"Report",RAPURTYP="B":"Exam & Report",1:"?")," records from "
+3 SET I=""
+4 FOR
SET I=$ORDER(RAPUR(I))
if 'I
QUIT
WRITE " ",$PIECE(^RA(79.2,I,0),U)
if $ORDER(RAPUR(I))
WRITE ","
+5 WRITE !
+6 SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you wish to proceed with the purge"
+7 SET DIR("?")="Enter 'YES' to go ahead with the purge, or 'NO' to exit from this option."
+8 DO ^DIR
KILL DIR
+9 SET RAGO=Y
+10 QUIT
REMIND ;
+1 ;;+--------------------------------------------------------+
+2 ;;| This option is used to remove data from one or all of |
+3 ;;| these globals: ^RADPT, ^RARPT |
+4 ;;| |
+5 ;;| Make sure IRM keeps the backup that was made prior to |
+6 ;;| running this option, and NOT overwrite that backup for |
+7 ;;| at least 6 months. Data from ^RADPT and ^RARPT can be |
+8 ;;| recovered. |
+9 ;;| |
+10 ;;| The cut-off dates for the 4 items (activity log, |
+11 ;;| report, clinical history, tracking time) are |
+12 ;;| compared to the exam date of those items. If the |
+13 ;;| exam date for an item is older than the cut-off date |
+14 ;;| for that item, then that item would be purged. |
+15 ;;+--------------------------------------------------------+
+16 ;;
+17 QUIT
