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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRGARC0 2576 printed Nov 22, 2024@17:05:20 Page 2
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
