GMRGARC0.m

GMRGARC0 ;HIRMFO/RM-ARCHIVE/PURGE UTILITY FOR GMR TEXT FILE ;4/15/96

 ;;3.0;Text Generator;**1**;Jan 24, 1996

 ;

EN1 ; Entry from the option Purge GMR Text File Data [GMRG-PURGE PT DATA]

 ;

 L +^GMRD(124.1,1,"PURGE"):1 I '$T W !!,"SOMEONE ELSE IS RUNNING THE PURGE OPTION, TRY AGAIN LATER!!" G Q

 I $P($G(^GMRD(124.1,1,"PURGE")),"^") W !!,"THE GMR TEXT FILE PURGE IS ALREADY RUNNING, TRY AGAIN LATER!!" G UNL

 K DIR S DIR("?")="   ENTER THE NUMBER OF MONTHS OF GMR TEXT DATA TO BE RETAINED.",DIR("?",1)="   YOU MUST RETAIN AT LEAST SIX MONTHS OF GMR TEXT DATA."

 S DIR(0)="NAO^6:99999",DIR("A")="Enter number of months to RETAIN GMR Text data: " W ! D ^DIR K DIR G UNL:'Y

 S GMRGPMO=Y,X="T-"_GMRGPMO_"M",%DT="" D ^%DT I Y<0 G UNL

 S GMRGPURG=Y,GMRGPURG(0)=$$FMTE^XLFDT(Y)

 S DIR("?")="   ANSWERING YES HERE CONFIRMS YOU WISH TO PURGE THE GMR TEXT DATA."

 S DIR("A",1)="Are you sure you only want to retain data from "_GMRGPURG(0),DIR("A")="to today (Y/N): ",DIR(0)="YA" W ! D ^DIR K DIR I Y'=1 G UNL

 S DIR("?")="   ANSWERING YES HERE WILL BEGIN THE PURGE.",DIR("B")="YES"

 S DIR("A")="OK to proceed: ",DIR(0)="YA" W ! D ^DIR K DIR I Y'=1 G UNL

 S ZTIO="",ZTRTN="START^GMRGARC0",ZTDESC="GMR Text File Date Purge",ZTSAVE("GMRGPURG")="" D ^%ZTLOAD I '$D(ZTSK) W !!,"Job not queued, please try again..." G UNL

 W !!,"Job queued as task #"_ZTSK

 S $P(^GMRD(124.1,1,"PURGE"),"^")=ZTSK

 S DA=1,DIK="^GMRD(124.1,",DIK(1)=2 D IX1^DIK

 K ZTSK

 G UNL

START ; Enter here from queued job

 ;

 ;  Input variable:  GMRGPURG=date to end loop for data purge

 ;

 S GMRGDATE=0 F  S GMRGDATE=$O(^GMR(124.3,"AUPDT",GMRGDATE)) Q:GMRGDATE'>0!(GMRGDATE>GMRGPURG)!$G(ZTSTOP)  S GMRGPDA=0 F  S GMRGPDA=$O(^GMR(124.3,"AUPDT",GMRGDATE,GMRGPDA)) Q:GMRGPDA'>0!$G(ZTSTOP)  D

 .   S DA=0 F  S DA=$O(^NURSC(216.8,"B",GMRGPDA,DA)) Q:DA'>0  S DIK="^NURSC(216.8," D ^DIK

 .   S DA=GMRGPDA,DIK="^GMR(124.3," D ^DIK

 .   I $$S^%ZTLOAD S ZTSTOP=1

 .   Q

 I '$G(ZTSTOP) S DIE="^GMRD(124.1,",DA=1,DR="2///@" D ^DIE

Q ; Clean up and exit

 I $D(ZTQUEUED),'$G(ZTSTOP) D

 .  S ZTREQ="@"

 .  N XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG

 .  S XQA(DUZ)="",XQAMSG="Purge is completed.  Restart journaling for the GMR and NURSC globals." D SETUP^XQALERT

 .  S XQA(DUZ)="",XQA("G.NURS-ADP")="",XQAMSG="Patient plan of care data older than "_$$FMTE^XLFDT(GMRGPURG,2)_" has been purged from the system." D SETUP^XQALERT

 .  Q

 K %DT,DA,DIE,DIK,DIR,DR,GMRGDATE,GMRGPDA,GMRGPMO,GMRGPURG,X,Y D ^%ZISC

 Q

UNL ; Unlock ^GMRD(124.1,1,"PURGE") and go to Q

 L -^GMRD(124.1,1,"PURGE")

 G Q

GMRGARC0  ;HIRMFO/RM-ARCHIVE/PURGE UTILITY FOR GMR TEXT FILE ;4/15/96

 +1       ;;3.0;Text Generator;**1**;Jan 24, 1996

 +2       ;

EN1       ; Entry from the option Purge GMR Text File Data [GMRG-PURGE PT DATA]

 +1       ;

 +2        LOCK +^GMRD(124.1,1,"PURGE"):1

           IF '$TEST

               WRITE !!,"SOMEONE ELSE IS RUNNING THE PURGE OPTION, TRY AGAIN LATER!!"

               GOTO Q

 +3        IF $PIECE($GET(^GMRD(124.1,1,"PURGE")),"^")

               WRITE !!,"THE GMR TEXT FILE PURGE IS ALREADY RUNNING, TRY AGAIN LATER!!"

               GOTO UNL

 +4        KILL DIR

           SET DIR("?")="   ENTER THE NUMBER OF MONTHS OF GMR TEXT DATA TO BE RETAINED."

           SET DIR("?",1)="   YOU MUST RETAIN AT LEAST SIX MONTHS OF GMR TEXT DATA."

 +5        SET DIR(0)="NAO^6:99999"

           SET DIR("A")="Enter number of months to RETAIN GMR Text data: "

           WRITE !

           DO ^DIR

           KILL DIR

           IF 'Y

               GOTO UNL

 +6        SET GMRGPMO=Y

           SET X="T-"_GMRGPMO_"M"

           SET %DT=""

           DO ^%DT

           IF Y<0

               GOTO UNL

 +7        SET GMRGPURG=Y

           SET GMRGPURG(0)=$$FMTE^XLFDT(Y)

 +8        SET DIR("?")="   ANSWERING YES HERE CONFIRMS YOU WISH TO PURGE THE GMR TEXT DATA."

 +9        SET DIR("A",1)="Are you sure you only want to retain data from "_GMRGPURG(0)

           SET DIR("A")="to today (Y/N): "

           SET DIR(0)="YA"

           WRITE !

           DO ^DIR

           KILL DIR

           IF Y'=1

               GOTO UNL

 +10       SET DIR("?")="   ANSWERING YES HERE WILL BEGIN THE PURGE."

           SET DIR("B")="YES"

 +11       SET DIR("A")="OK to proceed: "

           SET DIR(0)="YA"

           WRITE !

           DO ^DIR

           KILL DIR

           IF Y'=1

               GOTO UNL

 +12       SET ZTIO=""

           SET ZTRTN="START^GMRGARC0"

           SET ZTDESC="GMR Text File Date Purge"

           SET ZTSAVE("GMRGPURG")=""

           DO ^%ZTLOAD

           IF '$DATA(ZTSK)

               WRITE !!,"Job not queued, please try again..."

               GOTO UNL

 +13       WRITE !!,"Job queued as task #"_ZTSK

 +14       SET $PIECE(^GMRD(124.1,1,"PURGE"),"^")=ZTSK

 +15       SET DA=1

           SET DIK="^GMRD(124.1,"

           SET DIK(1)=2

           DO IX1^DIK

 +16       KILL ZTSK

 +17       GOTO UNL

START     ; Enter here from queued job

 +1       ;

 +2       ;  Input variable:  GMRGPURG=date to end loop for data purge

 +3       ;

 +4        SET GMRGDATE=0

           FOR 

               SET GMRGDATE=$ORDER(^GMR(124.3,"AUPDT",GMRGDATE))

               IF GMRGDATE'>0!(GMRGDATE>GMRGPURG)!$GET(ZTSTOP)

                   QUIT 

               SET GMRGPDA=0

               FOR 

                   SET GMRGPDA=$ORDER(^GMR(124.3,"AUPDT",GMRGDATE,GMRGPDA))

                   IF GMRGPDA'>0!$GET(ZTSTOP)

                       QUIT 

                   Begin DoDot:1

 +5                    SET DA=0

                       FOR 

                           SET DA=$ORDER(^NURSC(216.8,"B",GMRGPDA,DA))

                           IF DA'>0

                               QUIT 

                           SET DIK="^NURSC(216.8,"

                           DO ^DIK

 +6                    SET DA=GMRGPDA

                       SET DIK="^GMR(124.3,"

                       DO ^DIK

 +7                    IF $$S^%ZTLOAD

                           SET ZTSTOP=1

 +8                    QUIT 

                   End DoDot:1

 +9        IF '$GET(ZTSTOP)

               SET DIE="^GMRD(124.1,"

               SET DA=1

               SET DR="2///@"

               DO ^DIE

Q         ; Clean up and exit

 +1        IF $DATA(ZTQUEUED)

               IF '$GET(ZTSTOP)

                   Begin DoDot:1

 +2                    SET ZTREQ="@"

 +3                    NEW XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG

 +4                    SET XQA(DUZ)=""

                       SET XQAMSG="Purge is completed.  Restart journaling for the GMR and NURSC globals."

                       DO SETUP^XQALERT

 +5                    SET XQA(DUZ)=""

                       SET XQA("G.NURS-ADP")=""

                       SET XQAMSG="Patient plan of care data older than "_$$FMTE^XLFDT(GMRGPURG,2)_" has been purged from the system."

                       DO SETUP^XQALERT

 +6                    QUIT 

                   End DoDot:1

 +7        KILL %DT,DA,DIE,DIK,DIR,DR,GMRGDATE,GMRGPDA,GMRGPMO,GMRGPURG,X,Y

           DO ^%ZISC

 +8        QUIT 

UNL       ; Unlock ^GMRD(124.1,1,"PURGE") and go to Q

 +1        LOCK -^GMRD(124.1,1,"PURGE")

 +2        GOTO Q