- 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 Mar 13, 2025@21:24:10 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
