ENCTPRG ;(WASH ISC)/RGY-Purge Data from File 446.4 ;5-27-93
;;7.0;ENGINEERING;;Aug 17, 1993
;Copy of PRCTPRG ;DH-WASH ISC
F ENCTID=0:0 S ENCTID=$O(^PRCT(446.4,ENCTID)) Q:'ENCTID D PUR
TASK S X1=DT,X2=1 D C^%DTC S ZTIO="",ZTDTH=X_.01,$P(^($O(^PRCT(446.4,0)),0),"^",8)=X,ZTDESC="BARCODE DATA PURGE",ZTRTN="^ENCTPRG" D ^%ZTLOAD K ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN
Q K ENCTID Q
PUR Q:'$D(^PRCT(446.4,ENCTID,0))#2 S X2=$P(^(0),"^",7),$P(^(0),"^",8)=DT S:X2="" X2=7 S X1=DT,X2=-X2 D C^%DTC S ENCTNOD=X
F ENCT=0:0 S ENCT=$O(^PRCT(446.4,ENCTID,2,"B",ENCT)) Q:ENCT>ENCTNOD!'ENCT F ENCTTI=0:0 S ENCTTI=$O(^PRCT(446.4,ENCTID,2,"B",ENCT,ENCTTI)) Q:'ENCTTI S DA(1)=ENCTID,DA=ENCTTI,DIK="^PRCT(446.4,"_ENCTID_",2," D ^DIK
K ENCTNOD,ENCTTI,ENCT,DA,DIK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENCTPRG 752 printed Sep 23, 2025@19:28:17 Page 2
ENCTPRG ;(WASH ISC)/RGY-Purge Data from File 446.4 ;5-27-93
+1 ;;7.0;ENGINEERING;;Aug 17, 1993
+2 ;Copy of PRCTPRG ;DH-WASH ISC
+3 FOR ENCTID=0:0
SET ENCTID=$ORDER(^PRCT(446.4,ENCTID))
if 'ENCTID
QUIT
DO PUR
TASK SET X1=DT
SET X2=1
DO C^%DTC
SET ZTIO=""
SET ZTDTH=X_.01
SET $PIECE(^($ORDER(^PRCT(446.4,0)),0),"^",8)=X
SET ZTDESC="BARCODE DATA PURGE"
SET ZTRTN="^ENCTPRG"
DO ^%ZTLOAD
KILL ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN
Q KILL ENCTID
QUIT
PUR if '$DATA(^PRCT(446.4,ENCTID,0))#2
QUIT
SET X2=$PIECE(^(0),"^",7)
SET $PIECE(^(0),"^",8)=DT
if X2=""
SET X2=7
SET X1=DT
SET X2=-X2
DO C^%DTC
SET ENCTNOD=X
+1 FOR ENCT=0:0
SET ENCT=$ORDER(^PRCT(446.4,ENCTID,2,"B",ENCT))
if ENCT>ENCTNOD!'ENCT
QUIT
FOR ENCTTI=0:0
SET ENCTTI=$ORDER(^PRCT(446.4,ENCTID,2,"B",ENCT,ENCTTI))
if 'ENCTTI
QUIT
SET DA(1)=ENCTID
SET DA=ENCTTI
SET DIK="^PRCT(446.4,"_ENCTID_",2,"
DO ^DIK
+2 KILL ENCTNOD,ENCTTI,ENCT,DA,DIK
QUIT
