PRCTPRG.m

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 ---PRCTPRG   766     printed  Apr 09, 2024@21:12:55                                                                                                                                                                                                      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