RTPURGE ;PKE/ISC-ALBANY-Purge Data Routine; ; 5/27/87 11:45 AM ;
;;v 2.0;Record Tracking;;10/22/91
D DIP W !!,"Record Type Purge Parameters:",!,"-----------------------------"
DIE 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
W !!,"Overall Purge Parameters:",!,"-------------------------" S DA=1,DR="10;8;12",DIE="^DIC(195.4," D ^DIE K DE,DQ G Q:$D(Y)
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
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"
S RTPGM="START^RTPURGE",RTDESC="Record Tracking Purge Routine",RTVAR="",(IOM,IOST,ION)="" D Q^RTUTL S IOP="" D ^%ZIS K IOP G Q
;
START K RTFLAGS,RTT S (RTLSTQ,RTLSTP)=0 F I=10,8,12 S $P(RTFLAGS,"^",I)=$P(^DIC(195.4,1,0),"^",I)="y"
;
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"
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
;pull list
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
;requests
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
;movements
;Re-set last entry accessed
;
D RESET
Q 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
K DA,D0,DR,DIE Q
SET 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
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
S $P(RTT(RTYPE),"^",12)=$S($P(RTYPE0,"^",12):$P(RTYPE0,"^",12),1:50) K X1,X2 Q
;
RTP 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
I '$D(^RTV(190.1,"AP",RTP)) S DA=RTP,DIK="^RTV(194.2," D ^DIK K DIK
;pull list 194.2
Q
;
RTQ0 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))
RTQ I $D(^RT(+RTQ0,"CL")),RTQ=+^("CL") S DA=+RTQ0,DR="101///@",DIE="^RT(" D ^DIE K DE,DQ
S DA=RTQ,DIK="^RTV(190.1," D ^DIK K DIK
;
Q
;
RTH 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
S RTC=RTC-$P(RTT(T),"^",12)
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
RTHQ K RTH,RTC,RTC1,RTI,RTDT,DIK,DA Q
;
COUNT S X=0 F RTH=0:0 S RTH=$O(^RTV(190.3,"B",RT,RTH)) Q:'RTH S X=X+1
K RTH Q
;
DIP 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
Q
RESET S U2="^"
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
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
;
I $P(RTFLAGS,"^",12) D GAP
Q
GAP ;stops when 1/3 of z not consecutive
S (Z,Z1,Z2,Z3,I)=10000
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
I Z S $P(^RTV(190.3,0),"^",3)=Z1 L -^RTV(190.3,0) Q
E L +^RTV(190.3,0) S $P(^RTV(190.3,0),"^",3)=Z1 L -^RTV(190.3,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTPURGE 4050 printed Dec 13, 2024@02:34:26 Page 2
RTPURGE ;PKE/ISC-ALBANY-Purge Data Routine; ; 5/27/87 11:45 AM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
+2 DO DIP
WRITE !!,"Record Type Purge Parameters:",!,"-----------------------------"
DIE SET DIC("A")="Select RECORD TYPE: "
SET DIC="^DIC(195.2,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if X="^"
GOTO Q
IF Y>0
SET DA=+Y
SET DR="[RT PURGE PROFILE]"
SET DIE="^DIC(195.2,"
DO ^DIE
KILL DE,DQ
WRITE !
GOTO DIE
+1 WRITE !!,"Overall Purge Parameters:",!,"-------------------------"
SET DA=1
SET DR="10;8;12"
SET DIE="^DIC(195.4,"
DO ^DIE
KILL DE,DQ
if $DATA(Y)
GOTO Q
+2 SET X=^DIC(195.4,1,0)
IF $PIECE(X,"^",10)'="y"
IF $PIECE(X,"^",8)'="y"
IF $PIECE(X,"^",12)'="y"
WRITE !!?5,*7,"No data will be purged!"
GOTO Q
+3 SET RTRD(1)="Yes^indicate it is ok to run the purge option"
SET RTRD(2)="No^stop the purge process"
SET RTRD("B")=2
SET RTRD(0)="S"
SET RTRD("A")="Is it ok to continue? "
DO SET^RTRD
KILL RTRD
if $EXTRACT(X)'="Y"
GOTO Q
+4 SET RTPGM="START^RTPURGE"
SET RTDESC="Record Tracking Purge Routine"
SET RTVAR=""
SET (IOM,IOST,ION)=""
DO Q^RTUTL
SET IOP=""
DO ^%ZIS
KILL IOP
GOTO Q
+5 ;
START KILL RTFLAGS,RTT
SET (RTLSTQ,RTLSTP)=0
FOR I=10,8,12
SET $PIECE(RTFLAGS,"^",I)=$PIECE(^DIC(195.4,1,0),"^",I)="y"
+1 ;
+2 FOR RTYPE=0:0
SET RTYPE=$ORDER(^DIC(195.2,RTYPE))
if 'RTYPE
QUIT
IF $DATA(^(RTYPE,0))
SET RTYPE0=^(0)
if $PIECE(RTYPE0,"^",18)="y"
DO SET
+3 IF $PIECE(RTFLAGS,"^",10)
FOR RTDT=0:0
SET RTDT=$ORDER(^RTV(194.2,"C",RTDT))
if RTDT>RTLSTP!('RTDT)
QUIT
FOR RTP=0:0
SET RTP=$ORDER(^RTV(194.2,"C",RTDT,RTP))
if 'RTP
QUIT
DO RTP
+4 ;pull list
+5 IF $PIECE(RTFLAGS,"^",8)
FOR RTDT=0:0
SET RTDT=$ORDER(^RTV(190.1,"C",RTDT))
if RTDT>RTLSTQ!('RTDT)
QUIT
FOR RTQ=0:0
SET RTQ=$ORDER(^RTV(190.1,"C",RTDT,RTQ))
if 'RTQ
QUIT
IF $DATA(^RTV(190.1,RTQ,0))
SET RTQ0=^(0)
DO RTQ0
+6 ;requests
+7 IF $PIECE(RTFLAGS,"^",12)
FOR RT=0:0
SET RT=$ORDER(^RT(RT))
if 'RT
QUIT
IF $DATA(^RT(RT,0))
SET T=+$PIECE(^(0),"^",3)
SET RTHCL=$SELECT($DATA(^("CL")):+$PIECE(^("CL"),"^",2),1:0)
DO COUNT
IF $DATA(RTT(T))
IF X>+$PIECE(RTT(T),"^",12)
DO RTH
+8 ;movements
+9 ;Re-set last entry accessed
+10 ;
+11 DO RESET
Q KILL 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
DO CLOSE^RTUTL
+1 KILL DA,D0,DR,DIE
QUIT
SET SET X1=DT
SET X2=-$SELECT($PIECE(RTYPE0,"^",10):$PIECE(RTYPE0,"^",10),1:365)
DO C^%DTC
SET $PIECE(RTT(RTYPE),"^",10)=X
if RTLSTP'>X
SET RTLSTP=X
+1 SET X1=DT
SET X2=-$SELECT($PIECE(RTYPE0,"^",8):$PIECE(RTYPE0,"^",8),1:365)
DO C^%DTC
SET $PIECE(RTT(RTYPE),"^",8)=X
if RTLSTQ'>X
SET RTLSTQ=X
+2 SET $PIECE(RTT(RTYPE),"^",12)=$SELECT($PIECE(RTYPE0,"^",12):$PIECE(RTYPE0,"^",12),1:50)
KILL X1,X2
QUIT
+3 ;
RTP FOR RTQ=0:0
SET RTQ=$ORDER(^RTV(190.1,"AP",RTP,RTQ))
if 'RTQ
QUIT
IF $DATA(^RTV(190.1,RTQ,0))
SET RTQ0=^(0)
IF $DATA(^RT(+RTQ0,0))
SET T=+$PIECE(^(0),"^",3)
IF $DATA(RTT(T))
IF $PIECE(RTT(T),"^",10)>$PIECE(RTQ0,"^",4)
DO RTQ^RTDEL
DO RTQ
+1 IF '$DATA(^RTV(190.1,"AP",RTP))
SET DA=RTP
SET DIK="^RTV(194.2,"
DO ^DIK
KILL DIK
+2 ;pull list 194.2
+3 QUIT
+4 ;
RTQ0 if $SELECT($PIECE(RTQ0,"^",10)
QUIT
RTQ IF $DATA(^RT(+RTQ0,"CL"))
IF RTQ=+^("CL")
SET DA=+RTQ0
SET DR="101///@"
SET DIE="^RT("
DO ^DIE
KILL DE,DQ
+1 SET DA=RTQ
SET DIK="^RTV(190.1,"
DO ^DIK
KILL DIK
+2 ;
+3 QUIT
+4 ;
RTH SET RTC=0
FOR RTH=0:0
SET RTH=$ORDER(^RTV(190.3,"B",RT,RTH))
if 'RTH
QUIT
IF $DATA(^RTV(190.3,RTH,0))
SET X=+$PIECE(^(0),"^",6)
FOR I=1:1
IF '$DATA(RTH(I,X))
SET RTH(I,X)=RTH
SET RTC=RTC+1
QUIT
+1 SET RTC=RTC-$PIECE(RTT(T),"^",12)
+2 IF RTC>0
SET RTC1=0
FOR RTI=0:0
SET RTI=$ORDER(RTH(RTI))
if 'RTI
QUIT
FOR RTDT=0:0
SET RTDT=$ORDER(RTH(RTI,RTDT))
if 'RTDT
QUIT
SET DA=+RTH(RTI,RTDT)
SET DIK="^RTV(190.3,"
if DA'=RTHCL
DO ^DIK
SET RTC1=RTC1+1
if RTC'>RTC1
GOTO RTHQ
RTHQ KILL RTH,RTC,RTC1,RTI,RTDT,DIK,DA
QUIT
+1 ;
COUNT SET X=0
FOR RTH=0:0
SET RTH=$ORDER(^RTV(190.3,"B",RT,RTH))
if 'RTH
QUIT
SET X=X+1
+1 KILL RTH
QUIT
+2 ;
DIP WRITE !!?5,"...compiling purge profile"
SET IOP=""
SET DIC="^DIC(195.2,"
SET (BY,FLDS)="[RT PURGE PROFILE]"
SET L=0
KILL DTOUT
DO EN1^DIP
KILL DIC,FLDS,BY,L,TO,FR,IOP
QUIT
+1 QUIT
RESET SET U2="^"
+1 IF $PIECE(RTFLAGS,U2,10)
FOR I=1:1
IF '$DATA(^RTV(194.2,I,0))
LOCK +^RTV(194.2,0)
SET $PIECE(^RTV(194.2,0),"^",3)=$SELECT(I-1:I-1,1:"")
LOCK -^RTV(194.2,0)
QUIT
+2 IF $PIECE(RTFLAGS,"^",8)
FOR I=1:1
IF '$DATA(^RTV(190.1,I,0))
LOCK +^RTV(190.1,0)
SET $PIECE(^RTV(190.1,0),"^",3)=$SELECT(I-1:I-1,1:"")
LOCK -^RTV(190.1,0)
QUIT
+3 ;
+4 IF $PIECE(RTFLAGS,"^",12)
DO GAP
+5 QUIT
GAP ;stops when 1/3 of z not consecutive
+1 SET (Z,Z1,Z2,Z3,I)=10000
+2 FOR I=I:1
if I#1000=0
SET Z3=Z2
SET Z2=Z
SET Z1=Z
SET Z=$ORDER(^RTV(190.3,Z))
if 'Z
QUIT
IF I#1000=0
IF Z2-Z3>1333
LOCK +^RTV(190.3,0)
QUIT
+3 IF Z
SET $PIECE(^RTV(190.3,0),"^",3)=Z1
LOCK -^RTV(190.3,0)
QUIT
+4 IF '$TEST
LOCK +^RTV(190.3,0)
SET $PIECE(^RTV(190.3,0),"^",3)=Z1
LOCK -^RTV(190.3,0)
+5 QUIT
