- 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 Mar 13, 2025@20:59:49 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
