- 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 Dec 13, 2024@01:46:49 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