RAPURGE.m

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

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