source: WorldVistAEHR/trunk/r/ENGINEERING-EN/ENCTPRG.m@ 699

Last change on this file since 699 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 743 bytes
Line 
1ENCTPRG ;(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
5TASK 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
6Q K ENCTID Q
7PUR 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
Note: See TracBrowser for help on using the repository browser.