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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCTPRG 766 printed Nov 22, 2024@17:29:26 Page 2
PRCTPRG ;WISC@ALTOONA/RGY-WILL PURGE DATA FROM THE 446.4,2 FIELD ;01 Jun 90/3:26 PM
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 FOR PRCTID=0:0
SET PRCTID=$ORDER(^PRCT(446.4,PRCTID))
if 'PRCTID
QUIT
DO PUR
TASK SET X1=DT
SET X2=1
DO C^%DTC
SET ZTDTH=X_.01
SET $PIECE(^PRCT(446.4,PRCTID,0),"^",8)=X
SET ZTDESC="BARCODE DATA PURGE"
SET ZTRTN="^PRCTPRG"
DO ^%ZTLOAD
Q KILL PRCTID
QUIT
PUR if '$DATA(^PRCT(446.4,PRCTID,0))#2
QUIT
SET X2=$PIECE(^(0),"^",7)
SET $PIECE(^(0),"^",8)=DT
if X2=""
SET X2=7
SET X1=DT
SET X2=-X2
DO C^%DTC
SET PRCTNOD=X
+1 FOR PRCT=0:0
SET PRCT=$ORDER(^PRCT(446.4,PRCTID,2,"B",PRCT))
if PRCT>PRCTNOD!'PRCT
QUIT
FOR PRCTTI=0:0
SET PRCTTI=$ORDER(^PRCT(446.4,PRCTID,2,"B",PRCT,PRCTTI))
if 'PRCTTI
QUIT
SET DA(1)=PRCTID
SET DA=PRCTTI
SET DIK="^PRCT(446.4,"_PRCTID_",2,"
DO ^DIK
+2 KILL PRCTNOD,PRCTTI,PRCT,DA,DIK
QUIT
