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