source: WorldVistAEHR/trunk/r/NURSING_SERVICE-NUR/NURSADEL.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1NURSADEL ;CISC/MD/MH-PURGE ROUTINE FOR FILES 214.6 - 214.7 ;12/07/89
2 ;;4.0;NURSING SERVICE;;Apr 25, 1997
3EN1 ; ENTRY POINT TO PURGE DATA FROM FILES 214.6 AND 214.7
4 W !!,$C(7),"Has Nursing been contacted before purging data from files 214.6 and 214.7" S %=1 D YN^DICN
5 I %=0 W !!,$C(7),"ANSWER 'YES' or 'NO'" G EN1
6 I %=2 W !!!,$C(7),"Contact Nursing before proceeding!",! G Q
7 G:%'>0 Q
8EN1A W !!,$C(7),"Has journaling of ^NURSA global been stopped" S %=1 D YN^DICN
9 I %=0 W !!,$C(7),"ANSWER 'YES' OR 'NO'" G EN1A
10 I %=2 W !!!,$C(7),"Stop journaling of ^NURSA global before proceeding!",! G Q
11 G:%'>0 Q
12ASK 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
13 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
14 G ASK:%=2 Q:%'>0
15 D PURGE G:NUROUT Q D EN2,EN3
16 W !!,$C(7),"Purge is completed, journaling for the ^NURSA global should be restarted!"
17 S XQA("G.NURS-ADP")="",XQAMSG="Classification data older than "_NURSDATE(1)_" has been purged from the system." D SETUP^XQALERT
18Q D ^NURSKILL
19 Q
20PURGE ; ENTRY POINT TO PURGE DATA FROM THE NURSP(214.6 AND NURSP(214.7 GLOBALS
21 G:'$O(^NURSA(214.6,0)) AROUND W !!,"Purging 214.6 data.."
22 I '$D(^NURSA(214.6,"B")) W !,$C(7),"INCOMPLETE DATA FILE" S NUROUT=1 Q
23 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 "."
24 K ^NURSA(214.6,"B"),^NURSA(214.6,"C"),^NURSA(214.6,"AA"),^NURSA(214.6,"E"),^NURSA(214.6,"ACNT")
25AROUND Q:'$O(^NURSA(214.7,0)) W !!,"Purging 214.7 data .."
26 I '$D(^NURSA(214.7,"B")),$O(^NURSA(214.7,0)) W !,$C(7),"INCOMPLETE DATA FILE" S NUROUT=1 Q
27 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 "."
28 K ^NURSA(214.7,"B"),^NURSA(214.7,"C"),^NURSA(214.7,"AA"),^NURSA(214.7,"ACNT"),^NURSA(214.7,"E")
29 Q
30EN2 ;REINDEX FILES
31 Q:'$O(^NURSA(214.6,0)) W !,"Reindexing File 214.6 .."
32 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
33 S $P(^NURSA(214.6,0),U,3,4)=$P(NCT(1),U,1,2)
34 Q
35EN3 Q:'$O(^NURSA(214.7,0)) W !,"Reindexing File 214.7 .."
36 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
37 S $P(^NURSA(214.7,0),U,3,4)=$P(NCT(1),1,2)
38 Q
39INDX1 ;
40 S X=^NURSA(214.6,DA,0) I +$P(X,U) S ^NURSA(214.6,"B",+$P(X,U),DA)=""
41 I +$P(X,U,2) S ^NURSA(214.6,"C",+$P(X,U,2),DA)=""
42 I +$P(X,U),+$P(X,U,2) S ^NURSA(214.6,"AA",$P(X,U,2),9999999-$P(X,U),DA)=""
43 I +$P(X,U,8) S ^NURSA(214.6,"E",+$P(X,U,8),DA)=""
44 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
45 Q
46INDX2 ;
47 S X=^NURSA(214.7,DA,0) I +$P(X,U) S ^NURSA(214.7,"B",+$P(X,U),DA)=""
48 I +$P(X,U,2) S ^NURSA(214.7,"C",+$P(X,U,2),DA)=""
49 I +$P(X,U),+$P(X,U,2) S ^NURSA(214.7,"AA",$P(X,U,2),9999999-$P(X,U),DA)=""
50 I +$P(X,U,8) S ^NURSA(214.7,"E",+$P(X,U,8),DA)=""
51 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
52 Q
Note: See TracBrowser for help on using the repository browser.