PRCTPRG ;WISC@ALTOONA/RGY-WILL PURGE DATA FROM THE 446.4,2 FIELD ;01 Jun 90/3:26 PM
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 F PRCTID=0:0 S PRCTID=$O(^PRCT(446.4,PRCTID)) Q:'PRCTID  D PUR
TASK S X1=DT,X2=1 D C^%DTC S ZTDTH=X_.01,$P(^PRCT(446.4,PRCTID,0),"^",8)=X,ZTDESC="BARCODE DATA PURGE",ZTRTN="^PRCTPRG" D ^%ZTLOAD
Q K PRCTID Q
PUR Q:'$D(^PRCT(446.4,PRCTID,0))#2  S X2=$P(^(0),"^",7),$P(^(0),"^",8)=DT S:X2="" X2=7 S X1=DT,X2=-X2 D C^%DTC S PRCTNOD=X
 F PRCT=0:0 S PRCT=$O(^PRCT(446.4,PRCTID,2,"B",PRCT)) Q:PRCT>PRCTNOD!'PRCT  F PRCTTI=0:0 S PRCTTI=$O(^PRCT(446.4,PRCTID,2,"B",PRCT,PRCTTI)) Q:'PRCTTI  S DA(1)=PRCTID,DA=PRCTTI,DIK="^PRCT(446.4,"_PRCTID_",2," D ^DIK
 K PRCTNOD,PRCTTI,PRCT,DA,DIK Q