DENTPUR ; HISC/NCA - Purge Old Dental Activities ;8/16/96 10:37
;;1.2;DENTAL;**21,24**;JAN 26, 1989
S DENTYR=$E(DT,1,3)-5,DENTDTE=DENTYR_$E(DT,4,7)
D1 W !!,"Purge Prior To: ",$E(DENTDTE,4,5),"-",$E(DENTDTE,6,7),"-",(1700+$E(DENTDTE,1,3))," // " R X:DTIME G:'$T!(X="^") KIL G:X="" SITE S %DT="EXP" D ^%DT G:U[X!$D(DTOUT) KIL G:Y<1 D1
I Y>DENTDTE W *7,!!,"CANNOT PURGE DATA LATER THAN 5 YEARS!" G D1
S DENTDTE=+Y
SITE S DENTSTA=$O(^DENT(225,0)) I DENTSTA'<1,$O(^DENT(225,DENTSTA))<1 S DENTSTA=$P($G(^DENT(225,DENTSTA,0)),"^",1) G D2
W !! S DIC="^DENT(225,",DIC(0)="AEMQ" D ^DIC G:Y<0 KIL S DENTSTA=$P(Y,"^",2) K DIC
D2 K ZTUCI,ZTDTH,ZTIO,ZTSAVE S ZTRTN="Q1^DENTPUR",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("DENTDTE")="",ZTSAVE("DENTSTA")=""
W !!,"Request will be Queued."
S ZTIO="",ZTDESC="Purge Old Dental Activities." D ^%ZTLOAD K ZTSK Q
Q1 ; Process Purge
F DENTD=0:0 S DENTD=$O(^DENT(221,DENTD)) Q:DENTD<1 S X=$G(^(DENTD,0)),DENTX=$P(X,"^",1),DENTX1=$P(X,"^",40) I DENTX1=DENTSTA,DENTX<DENTDTE S DENTFLE=221 D K0
F DENTD=0:0 S DENTD=$O(^DENT(222,DENTD)) Q:DENTD<1 S X=$G(^(DENTD,0)),DENTX=$P(X,"^",1),DENTX1=$P(X,"^",28) I DENTX1=DENTSTA,DENTX<DENTDTE S DENTFLE=222 D K0
F DENTD=0:0 S DENTD=$O(^DENT(223,DENTD)) Q:DENTD<1 S X=$G(^(DENTD,0)),DENTX=$P(X,"^",1),DENTX1=$P(X,"^",29) I DENTX1=DENTSTA,DENTX<DENTDTE S DENTFLE=223 D K0
F DENTD=0:0 S DENTD=$O(^DENT(224,DENTD)) Q:DENTD<1 S X=$G(^(DENTD,0)),DENTX=$P(X,"^",1),DENTX1=$P(X,"^",10) I DENTX1=DENTSTA,DENTX<DENTDTE S DENTFLE=224 D K0
F DENTD=0:0 S DENTD=$O(^DENT(226,DENTD)) Q:DENTD<1 S X=$G(^(DENTD,0)),DENTX=$P(X,"^",1),DENTX1=$P(X,"^",2) I DENTX1=DENTSTA,DENTX<DENTDTE S DENTFLE=226 D K0
KIL K %DT,DA,DENTD,DENTDTE,DENTFLE,DENTSTA,DENTX,DENTX1,DENTYR,DIC,DIK,X,Y Q
K0 S DIK="^DENT("_DENTFLE_",",DA=DENTD D ^DIK K DIK,DA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTPUR 1813 printed May 14, 2023@14:13:22 Page 2
DENTPUR ; HISC/NCA - Purge Old Dental Activities ;8/16/96 10:37
+1 ;;1.2;DENTAL;**21,24**;JAN 26, 1989
+2 SET DENTYR=$EXTRACT(DT,1,3)-5
SET DENTDTE=DENTYR_$EXTRACT(DT,4,7)
D1 WRITE !!,"Purge Prior To: ",$EXTRACT(DENTDTE,4,5),"-",$EXTRACT(DENTDTE,6,7),"-",(1700+$EXTRACT(DENTDTE,1,3))," // "
READ X:DTIME
if '$TEST!(X="^")
GOTO KIL
if X=""
GOTO SITE
SET %DT="EXP"
DO ^%DT
if U[X!$DATA(DTOUT)
GOTO KIL
if Y<1
GOTO D1
+1 IF Y>DENTDTE
WRITE *7,!!,"CANNOT PURGE DATA LATER THAN 5 YEARS!"
GOTO D1
+2 SET DENTDTE=+Y
SITE SET DENTSTA=$ORDER(^DENT(225,0))
IF DENTSTA'<1
IF $ORDER(^DENT(225,DENTSTA))<1
SET DENTSTA=$PIECE($GET(^DENT(225,DENTSTA,0)),"^",1)
GOTO D2
+1 WRITE !!
SET DIC="^DENT(225,"
SET DIC(0)="AEMQ"
DO ^DIC
if Y<0
GOTO KIL
SET DENTSTA=$PIECE(Y,"^",2)
KILL DIC
D2 KILL ZTUCI,ZTDTH,ZTIO,ZTSAVE
SET ZTRTN="Q1^DENTPUR"
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
SET ZTSAVE("DENTDTE")=""
SET ZTSAVE("DENTSTA")=""
+1 WRITE !!,"Request will be Queued."
+2 SET ZTIO=""
SET ZTDESC="Purge Old Dental Activities."
DO ^%ZTLOAD
KILL ZTSK
QUIT
Q1 ; Process Purge
+1 FOR DENTD=0:0
SET DENTD=$ORDER(^DENT(221,DENTD))
if DENTD<1
QUIT
SET X=$GET(^(DENTD,0))
SET DENTX=$PIECE(X,"^",1)
SET DENTX1=$PIECE(X,"^",40)
IF DENTX1=DENTSTA
IF DENTX<DENTDTE
SET DENTFLE=221
DO K0
+2 FOR DENTD=0:0
SET DENTD=$ORDER(^DENT(222,DENTD))
if DENTD<1
QUIT
SET X=$GET(^(DENTD,0))
SET DENTX=$PIECE(X,"^",1)
SET DENTX1=$PIECE(X,"^",28)
IF DENTX1=DENTSTA
IF DENTX<DENTDTE
SET DENTFLE=222
DO K0
+3 FOR DENTD=0:0
SET DENTD=$ORDER(^DENT(223,DENTD))
if DENTD<1
QUIT
SET X=$GET(^(DENTD,0))
SET DENTX=$PIECE(X,"^",1)
SET DENTX1=$PIECE(X,"^",29)
IF DENTX1=DENTSTA
IF DENTX<DENTDTE
SET DENTFLE=223
DO K0
+4 FOR DENTD=0:0
SET DENTD=$ORDER(^DENT(224,DENTD))
if DENTD<1
QUIT
SET X=$GET(^(DENTD,0))
SET DENTX=$PIECE(X,"^",1)
SET DENTX1=$PIECE(X,"^",10)
IF DENTX1=DENTSTA
IF DENTX<DENTDTE
SET DENTFLE=224
DO K0
+5 FOR DENTD=0:0
SET DENTD=$ORDER(^DENT(226,DENTD))
if DENTD<1
QUIT
SET X=$GET(^(DENTD,0))
SET DENTX=$PIECE(X,"^",1)
SET DENTX1=$PIECE(X,"^",2)
IF DENTX1=DENTSTA
IF DENTX<DENTDTE
SET DENTFLE=226
DO K0
KIL KILL %DT,DA,DENTD,DENTDTE,DENTFLE,DENTSTA,DENTX,DENTX1,DENTYR,DIC,DIK,X,Y
QUIT
K0 SET DIK="^DENT("_DENTFLE_","
SET DA=DENTD
DO ^DIK
KILL DIK,DA
QUIT
