source: WorldVistAEHR/trunk/r/RECORD_TRACKING-RT/RTPURGE.m@ 701

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1RTPURGE ;PKE/ISC-ALBANY-Purge Data Routine; ; 5/27/87 11:45 AM ;
2 ;;v 2.0;Record Tracking;;10/22/91
3 D DIP W !!,"Record Type Purge Parameters:",!,"-----------------------------"
4DIE S DIC("A")="Select RECORD TYPE: ",DIC="^DIC(195.2,",DIC(0)="AEMQ" D ^DIC K DIC G Q:X="^" I Y>0 S DA=+Y,DR="[RT PURGE PROFILE]",DIE="^DIC(195.2," D ^DIE K DE,DQ W ! G DIE
5 W !!,"Overall Purge Parameters:",!,"-------------------------" S DA=1,DR="10;8;12",DIE="^DIC(195.4," D ^DIE K DE,DQ G Q:$D(Y)
6 S X=^DIC(195.4,1,0) I $P(X,"^",10)'="y",$P(X,"^",8)'="y",$P(X,"^",12)'="y" W !!?5,*7,"No data will be purged!" G Q
7 S RTRD(1)="Yes^indicate it is ok to run the purge option",RTRD(2)="No^stop the purge process",RTRD("B")=2,RTRD(0)="S",RTRD("A")="Is it ok to continue? " D SET^RTRD K RTRD G Q:$E(X)'="Y"
8 S RTPGM="START^RTPURGE",RTDESC="Record Tracking Purge Routine",RTVAR="",(IOM,IOST,ION)="" D Q^RTUTL S IOP="" D ^%ZIS K IOP G Q
9 ;
10START K RTFLAGS,RTT S (RTLSTQ,RTLSTP)=0 F I=10,8,12 S $P(RTFLAGS,"^",I)=$P(^DIC(195.4,1,0),"^",I)="y"
11 ;
12 F RTYPE=0:0 S RTYPE=$O(^DIC(195.2,RTYPE)) Q:'RTYPE I $D(^(RTYPE,0)) S RTYPE0=^(0) D SET:$P(RTYPE0,"^",18)="y"
13 I $P(RTFLAGS,"^",10) F RTDT=0:0 S RTDT=$O(^RTV(194.2,"C",RTDT)) Q:RTDT>RTLSTP!('RTDT) F RTP=0:0 S RTP=$O(^RTV(194.2,"C",RTDT,RTP)) Q:'RTP D RTP
14 ;pull list
15 I $P(RTFLAGS,"^",8) F RTDT=0:0 S RTDT=$O(^RTV(190.1,"C",RTDT)) Q:RTDT>RTLSTQ!('RTDT) F RTQ=0:0 S RTQ=$O(^RTV(190.1,"C",RTDT,RTQ)) Q:'RTQ I $D(^RTV(190.1,RTQ,0)) S RTQ0=^(0) D RTQ0
16 ;requests
17 I $P(RTFLAGS,"^",12) F RT=0:0 S RT=$O(^RT(RT)) Q:'RT I $D(^RT(RT,0)) S T=+$P(^(0),"^",3),RTHCL=$S($D(^("CL")):+$P(^("CL"),"^",2),1:0) D COUNT I $D(RTT(T)),X>+$P(RTT(T),"^",12) D RTH
18 ;movements
19 ;Re-set last entry accessed
20 ;
21 D RESET
22Q K U2,Z,Z1,Z2,Z3,I,RTHCL,RTVAR,RT,RT0,RTC,RTC1,RTDT,RTFLAGS,RTH,RTI,RTLSTP,RTLSTQ,RTP,RTQ,RTQ0,RTRD,RTT,RTYPE,TYPE0 D CLOSE^RTUTL
23 K DA,D0,DR,DIE Q
24SET S X1=DT,X2=-$S($P(RTYPE0,"^",10):$P(RTYPE0,"^",10),1:365) D C^%DTC S $P(RTT(RTYPE),"^",10)=X S:RTLSTP'>X RTLSTP=X
25 S X1=DT,X2=-$S($P(RTYPE0,"^",8):$P(RTYPE0,"^",8),1:365) D C^%DTC S $P(RTT(RTYPE),"^",8)=X S:RTLSTQ'>X RTLSTQ=X
26 S $P(RTT(RTYPE),"^",12)=$S($P(RTYPE0,"^",12):$P(RTYPE0,"^",12),1:50) K X1,X2 Q
27 ;
28RTP F RTQ=0:0 S RTQ=$O(^RTV(190.1,"AP",RTP,RTQ)) Q:'RTQ I $D(^RTV(190.1,RTQ,0)) S RTQ0=^(0) I $D(^RT(+RTQ0,0)) S T=+$P(^(0),"^",3) I $D(RTT(T)),$P(RTT(T),"^",10)>$P(RTQ0,"^",4) D RTQ^RTDEL,RTQ
29 I '$D(^RTV(190.1,"AP",RTP)) S DA=RTP,DIK="^RTV(194.2," D ^DIK K DIK
30 ;pull list 194.2
31 Q
32 ;
33RTQ0 Q:$S($P(RTQ0,"^",10):1,'$D(^RT(+RTQ0,0)):0,'$D(RTT(+$P(^(0),"^",3))):1,1:+$P(RTT(+$P(^(0),"^",3)),"^",8)'>$P(RTQ0,"^",4))
34RTQ I $D(^RT(+RTQ0,"CL")),RTQ=+^("CL") S DA=+RTQ0,DR="101///@",DIE="^RT(" D ^DIE K DE,DQ
35 S DA=RTQ,DIK="^RTV(190.1," D ^DIK K DIK
36 ;
37 Q
38 ;
39RTH S RTC=0 F RTH=0:0 S RTH=$O(^RTV(190.3,"B",RT,RTH)) Q:'RTH I $D(^RTV(190.3,RTH,0)) S X=+$P(^(0),"^",6) F I=1:1 I '$D(RTH(I,X)) S RTH(I,X)=RTH,RTC=RTC+1 Q
40 S RTC=RTC-$P(RTT(T),"^",12)
41 I RTC>0 S RTC1=0 F RTI=0:0 S RTI=$O(RTH(RTI)) Q:'RTI F RTDT=0:0 S RTDT=$O(RTH(RTI,RTDT)) Q:'RTDT S DA=+RTH(RTI,RTDT),DIK="^RTV(190.3," D ^DIK:DA'=RTHCL S RTC1=RTC1+1 G RTHQ:RTC'>RTC1
42RTHQ K RTH,RTC,RTC1,RTI,RTDT,DIK,DA Q
43 ;
44COUNT S X=0 F RTH=0:0 S RTH=$O(^RTV(190.3,"B",RT,RTH)) Q:'RTH S X=X+1
45 K RTH Q
46 ;
47DIP W !!?5,"...compiling purge profile" S IOP="",DIC="^DIC(195.2,",(BY,FLDS)="[RT PURGE PROFILE]",L=0 K DTOUT D EN1^DIP K DIC,FLDS,BY,L,TO,FR,IOP Q
48 Q
49RESET S U2="^"
50 I $P(RTFLAGS,U2,10) F I=1:1 I '$D(^RTV(194.2,I,0)) L +^RTV(194.2,0) S $P(^RTV(194.2,0),"^",3)=$S(I-1:I-1,1:"") L -^RTV(194.2,0) Q
51 I $P(RTFLAGS,"^",8) F I=1:1 I '$D(^RTV(190.1,I,0)) L +^RTV(190.1,0) S $P(^RTV(190.1,0),"^",3)=$S(I-1:I-1,1:"") L -^RTV(190.1,0) Q
52 ;
53 I $P(RTFLAGS,"^",12) D GAP
54 Q
55GAP ;stops when 1/3 of z not consecutive
56 S (Z,Z1,Z2,Z3,I)=10000
57 F I=I:1 S:I#1000=0 Z3=Z2,Z2=Z S Z1=Z,Z=$O(^RTV(190.3,Z)) Q:'Z IF I#1000=0,Z2-Z3>1333 L +^RTV(190.3,0) Q
58 I Z S $P(^RTV(190.3,0),"^",3)=Z1 L -^RTV(190.3,0) Q
59 E L +^RTV(190.3,0) S $P(^RTV(190.3,0),"^",3)=Z1 L -^RTV(190.3,0)
60 Q
Note: See TracBrowser for help on using the repository browser.