| 1 | PRCTPRG ;WISC@ALTOONA/RGY-WILL PURGE DATA FROM THE 446.4,2 FIELD ;01 Jun 90/3:26 PM
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | F PRCTID=0:0 S PRCTID=$O(^PRCT(446.4,PRCTID)) Q:'PRCTID D PUR
|
|---|
| 5 | 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
|
|---|
| 6 | Q K PRCTID Q
|
|---|
| 7 | 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
|
|---|
| 8 | 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
|
|---|
| 9 | K PRCTNOD,PRCTTI,PRCT,DA,DIK Q
|
|---|
