10 lines
743 B
Mathematica
10 lines
743 B
Mathematica
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
|