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