- 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 Feb 18, 2025@23:47:46 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
