| [613] | 1 | ENCTPRG ;(WASH ISC)/RGY-Purge Data from File 446.4 ;5-27-93
|
|---|
| 2 | ;;7.0;ENGINEERING;;Aug 17, 1993
|
|---|
| 3 | ;Copy of PRCTPRG ;DH-WASH ISC
|
|---|
| 4 | F ENCTID=0:0 S ENCTID=$O(^PRCT(446.4,ENCTID)) Q:'ENCTID D PUR
|
|---|
| 5 | 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
|
|---|
| 6 | Q K ENCTID Q
|
|---|
| 7 | 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
|
|---|
| 8 | 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
|
|---|
| 9 | K ENCTNOD,ENCTTI,ENCT,DA,DIK Q
|
|---|
