NURSADEL ;CISC/MD/MH-PURGE ROUTINE FOR FILES 214.6 - 214.7 ;12/07/89
;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; ENTRY POINT TO PURGE DATA FROM FILES 214.6 AND 214.7
W !!,$C(7),"Has Nursing been contacted before purging data from files 214.6 and 214.7" S %=1 D YN^DICN
I %=0 W !!,$C(7),"ANSWER 'YES' or 'NO'" G EN1
I %=2 W !!!,$C(7),"Contact Nursing before proceeding!",! G Q
G:%'>0 Q
EN1A W !!,$C(7),"Has journaling of ^NURSA global been stopped" S %=1 D YN^DICN
I %=0 W !!,$C(7),"ANSWER 'YES' OR 'NO'" G EN1A
I %=2 W !!!,$C(7),"Stop journaling of ^NURSA global before proceeding!",! G Q
G:%'>0 Q
ASK W ! S NUROUT=0,U="^",X="T-6M",%DT="" D ^%DT S NURSDATE=+Y D D^DIQ S %DT("A")="Start With: ",%DT("B")=Y,%DT(0)=-NURSDATE,%DT="AEPT" D ^%DT G Q:+Y'>0 S NURSDATE=+Y
W !!,"Are you sure you want to delete data older than " D DT^DIQ S NURSDATE(1)=Y,%=1 D YN^DICN I '% W $C(7),!,?4,"ANSWER 'YES' OR 'NO':" G ASK
G ASK:%=2 Q:%'>0
D PURGE G:NUROUT Q D EN2,EN3
W !!,$C(7),"Purge is completed, journaling for the ^NURSA global should be restarted!"
S XQA("G.NURS-ADP")="",XQAMSG="Classification data older than "_NURSDATE(1)_" has been purged from the system." D SETUP^XQALERT
Q D ^NURSKILL
Q
PURGE ; ENTRY POINT TO PURGE DATA FROM THE NURSP(214.6 AND NURSP(214.7 GLOBALS
G:'$O(^NURSA(214.6,0)) AROUND W !!,"Purging 214.6 data.."
I '$D(^NURSA(214.6,"B")) W !,$C(7),"INCOMPLETE DATA FILE" S NUROUT=1 Q
F DA=0:0 S DA=$O(^NURSA(214.6,"B",DA)) Q:+DA>NURSDATE!(DA'>0) F IEN=0:0 S IEN=$O(^NURSA(214.6,"B",DA,IEN)) Q:IEN'>0 K ^NURSA(214.6,IEN) W "."
K ^NURSA(214.6,"B"),^NURSA(214.6,"C"),^NURSA(214.6,"AA"),^NURSA(214.6,"E"),^NURSA(214.6,"ACNT")
AROUND Q:'$O(^NURSA(214.7,0)) W !!,"Purging 214.7 data .."
I '$D(^NURSA(214.7,"B")),$O(^NURSA(214.7,0)) W !,$C(7),"INCOMPLETE DATA FILE" S NUROUT=1 Q
F DA=0:0 S DA=$O(^NURSA(214.7,"B",DA)) Q:+DA>NURSDATE!(DA'>0) F IEN=0:0 S IEN=$O(^NURSA(214.7,"B",DA,IEN)) Q:IEN'>0 K ^NURSA(214.7,IEN) W "."
K ^NURSA(214.7,"B"),^NURSA(214.7,"C"),^NURSA(214.7,"AA"),^NURSA(214.7,"ACNT"),^NURSA(214.7,"E")
Q
EN2 ;REINDEX FILES
Q:'$O(^NURSA(214.6,0)) W !,"Reindexing File 214.6 .."
S (NCT,NCT(1))=0 I $D(^NURSA(214.6,0)) F DA=0:0 S DA=$O(^NURSA(214.6,DA)) Q:DA'>0 S NCT=NCT+1,NCT(1)=DA_U_NCT W "." D INDX1
S $P(^NURSA(214.6,0),U,3,4)=$P(NCT(1),U,1,2)
Q
EN3 Q:'$O(^NURSA(214.7,0)) W !,"Reindexing File 214.7 .."
S (NCT,NCT(1))=0 I $D(^NURSA(214.7,0)) F DA=0:0 S DA=$O(^NURSA(214.7,DA)) Q:DA'>0 S NCT=NCT+1,NCT(1)=DA_U_NCT W "." D INDX2
S $P(^NURSA(214.7,0),U,3,4)=$P(NCT(1),1,2)
Q
INDX1 ;
S X=^NURSA(214.6,DA,0) I +$P(X,U) S ^NURSA(214.6,"B",+$P(X,U),DA)=""
I +$P(X,U,2) S ^NURSA(214.6,"C",+$P(X,U,2),DA)=""
I +$P(X,U),+$P(X,U,2) S ^NURSA(214.6,"AA",$P(X,U,2),9999999-$P(X,U),DA)=""
I +$P(X,U,8) S ^NURSA(214.6,"E",+$P(X,U,8),DA)=""
I $P(X,U,10)'="",+$P(X,U),+$P(X,U,8) S ZX=$S($P(X,U,10)="H":$P(X,U,10),$P(X,U,10)="R":$P(X,U,10),1:"") I ZX'="" S ^NURSA(214.6,"ACNT",$P(X,U)\1,+$P(X,U,8),ZX,DA)="" K X
Q
INDX2 ;
S X=^NURSA(214.7,DA,0) I +$P(X,U) S ^NURSA(214.7,"B",+$P(X,U),DA)=""
I +$P(X,U,2) S ^NURSA(214.7,"C",+$P(X,U,2),DA)=""
I +$P(X,U),+$P(X,U,2) S ^NURSA(214.7,"AA",$P(X,U,2),9999999-$P(X,U),DA)=""
I +$P(X,U,8) S ^NURSA(214.7,"E",+$P(X,U,8),DA)=""
I $P(X,U,10)'="",+$P(X,U),+$P(X,U,8) S ZX=$S($P(X,U,10)="H":$P(X,U,10),$P(X,U,10)="R":$P(X,U,10),1:"") I ZX'="" S ^NURSA(214.7,"ACNT",$P(X,U)\1,+$P(X,U,8),ZX,DA)="" K ZX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURSADEL 3438 printed Dec 13, 2024@02:21:21 Page 2
NURSADEL ;CISC/MD/MH-PURGE ROUTINE FOR FILES 214.6 - 214.7 ;12/07/89
+1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
EN1 ; ENTRY POINT TO PURGE DATA FROM FILES 214.6 AND 214.7
+1 WRITE !!,$CHAR(7),"Has Nursing been contacted before purging data from files 214.6 and 214.7"
SET %=1
DO YN^DICN
+2 IF %=0
WRITE !!,$CHAR(7),"ANSWER 'YES' or 'NO'"
GOTO EN1
+3 IF %=2
WRITE !!!,$CHAR(7),"Contact Nursing before proceeding!",!
GOTO Q
+4 if %'>0
GOTO Q
EN1A WRITE !!,$CHAR(7),"Has journaling of ^NURSA global been stopped"
SET %=1
DO YN^DICN
+1 IF %=0
WRITE !!,$CHAR(7),"ANSWER 'YES' OR 'NO'"
GOTO EN1A
+2 IF %=2
WRITE !!!,$CHAR(7),"Stop journaling of ^NURSA global before proceeding!",!
GOTO Q
+3 if %'>0
GOTO Q
ASK WRITE !
SET NUROUT=0
SET U="^"
SET X="T-6M"
SET %DT=""
DO ^%DT
SET NURSDATE=+Y
DO D^DIQ
SET %DT("A")="Start With: "
SET %DT("B")=Y
SET %DT(0)=-NURSDATE
SET %DT="AEPT"
DO ^%DT
if +Y'>0
GOTO Q
SET NURSDATE=+Y
+1 WRITE !!,"Are you sure you want to delete data older than "
DO DT^DIQ
SET NURSDATE(1)=Y
SET %=1
DO YN^DICN
IF '%
WRITE $CHAR(7),!,?4,"ANSWER 'YES' OR 'NO':"
GOTO ASK
+2 if %=2
GOTO ASK
if %'>0
QUIT
+3 DO PURGE
if NUROUT
GOTO Q
DO EN2
DO EN3
+4 WRITE !!,$CHAR(7),"Purge is completed, journaling for the ^NURSA global should be restarted!"
+5 SET XQA("G.NURS-ADP")=""
SET XQAMSG="Classification data older than "_NURSDATE(1)_" has been purged from the system."
DO SETUP^XQALERT
Q DO ^NURSKILL
+1 QUIT
PURGE ; ENTRY POINT TO PURGE DATA FROM THE NURSP(214.6 AND NURSP(214.7 GLOBALS
+1 if '$ORDER(^NURSA(214.6,0))
GOTO AROUND
WRITE !!,"Purging 214.6 data.."
+2 IF '$DATA(^NURSA(214.6,"B"))
WRITE !,$CHAR(7),"INCOMPLETE DATA FILE"
SET NUROUT=1
QUIT
+3 FOR DA=0:0
SET DA=$ORDER(^NURSA(214.6,"B",DA))
if +DA>NURSDATE!(DA'>0)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^NURSA(214.6,"B",DA,IEN))
if IEN'>0
QUIT
KILL ^NURSA(214.6,IEN)
WRITE "."
+4 KILL ^NURSA(214.6,"B"),^NURSA(214.6,"C"),^NURSA(214.6,"AA"),^NURSA(214.6,"E"),^NURSA(214.6,"ACNT")
AROUND if '$ORDER(^NURSA(214.7,0))
QUIT
WRITE !!,"Purging 214.7 data .."
+1 IF '$DATA(^NURSA(214.7,"B"))
IF $ORDER(^NURSA(214.7,0))
WRITE !,$CHAR(7),"INCOMPLETE DATA FILE"
SET NUROUT=1
QUIT
+2 FOR DA=0:0
SET DA=$ORDER(^NURSA(214.7,"B",DA))
if +DA>NURSDATE!(DA'>0)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^NURSA(214.7,"B",DA,IEN))
if IEN'>0
QUIT
KILL ^NURSA(214.7,IEN)
WRITE "."
+3 KILL ^NURSA(214.7,"B"),^NURSA(214.7,"C"),^NURSA(214.7,"AA"),^NURSA(214.7,"ACNT"),^NURSA(214.7,"E")
+4 QUIT
EN2 ;REINDEX FILES
+1 if '$ORDER(^NURSA(214.6,0))
QUIT
WRITE !,"Reindexing File 214.6 .."
+2 SET (NCT,NCT(1))=0
IF $DATA(^NURSA(214.6,0))
FOR DA=0:0
SET DA=$ORDER(^NURSA(214.6,DA))
if DA'>0
QUIT
SET NCT=NCT+1
SET NCT(1)=DA_U_NCT
WRITE "."
DO INDX1
+3 SET $PIECE(^NURSA(214.6,0),U,3,4)=$PIECE(NCT(1),U,1,2)
+4 QUIT
EN3 if '$ORDER(^NURSA(214.7,0))
QUIT
WRITE !,"Reindexing File 214.7 .."
+1 SET (NCT,NCT(1))=0
IF $DATA(^NURSA(214.7,0))
FOR DA=0:0
SET DA=$ORDER(^NURSA(214.7,DA))
if DA'>0
QUIT
SET NCT=NCT+1
SET NCT(1)=DA_U_NCT
WRITE "."
DO INDX2
+2 SET $PIECE(^NURSA(214.7,0),U,3,4)=$PIECE(NCT(1),1,2)
+3 QUIT
INDX1 ;
+1 SET X=^NURSA(214.6,DA,0)
IF +$PIECE(X,U)
SET ^NURSA(214.6,"B",+$PIECE(X,U),DA)=""
+2 IF +$PIECE(X,U,2)
SET ^NURSA(214.6,"C",+$PIECE(X,U,2),DA)=""
+3 IF +$PIECE(X,U)
IF +$PIECE(X,U,2)
SET ^NURSA(214.6,"AA",$PIECE(X,U,2),9999999-$PIECE(X,U),DA)=""
+4 IF +$PIECE(X,U,8)
SET ^NURSA(214.6,"E",+$PIECE(X,U,8),DA)=""
+5 IF $PIECE(X,U,10)'=""
IF +$PIECE(X,U)
IF +$PIECE(X,U,8)
SET ZX=$SELECT($PIECE(X,U,10)="H":$PIECE(X,U,10),$PIECE(X,U,10)="R":$PIECE(X,U,10),1:"")
IF ZX'=""
SET ^NURSA(214.6,"ACNT",$PIECE(X,U)\1,+$PIECE(X,U,8),ZX,DA)=""
KILL X
+6 QUIT
INDX2 ;
+1 SET X=^NURSA(214.7,DA,0)
IF +$PIECE(X,U)
SET ^NURSA(214.7,"B",+$PIECE(X,U),DA)=""
+2 IF +$PIECE(X,U,2)
SET ^NURSA(214.7,"C",+$PIECE(X,U,2),DA)=""
+3 IF +$PIECE(X,U)
IF +$PIECE(X,U,2)
SET ^NURSA(214.7,"AA",$PIECE(X,U,2),9999999-$PIECE(X,U),DA)=""
+4 IF +$PIECE(X,U,8)
SET ^NURSA(214.7,"E",+$PIECE(X,U,8),DA)=""
+5 IF $PIECE(X,U,10)'=""
IF +$PIECE(X,U)
IF +$PIECE(X,U,8)
SET ZX=$SELECT($PIECE(X,U,10)="H":$PIECE(X,U,10),$PIECE(X,U,10)="R":$PIECE(X,U,10),1:"")
IF ZX'=""
SET ^NURSA(214.7,"ACNT",$PIECE(X,U)\1,+$PIECE(X,U,8),ZX,DA)=""
KILL ZX
+6 QUIT
