ENCTPRG.m

ENCTPRG ;(WASH ISC)/RGY-Purge Data from File 446.4 ;5-27-93

 ;;7.0;ENGINEERING;;Aug 17, 1993

 ;Copy of PRCTPRG ;DH-WASH ISC

 F ENCTID=0:0 S ENCTID=$O(^PRCT(446.4,ENCTID)) Q:'ENCTID  D PUR

TASK 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

Q K ENCTID Q

PUR 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

 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

 K ENCTNOD,ENCTTI,ENCT,DA,DIK Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ENCTPRG   752     printed  Apr 09, 2024@21:01:27                                                                                                                                                                                                      Page 2

ENCTPRG   ;(WASH ISC)/RGY-Purge Data from File 446.4 ;5-27-93

 +1       ;;7.0;ENGINEERING;;Aug 17, 1993

 +2       ;Copy of PRCTPRG ;DH-WASH ISC

 +3        FOR ENCTID=0:0

               SET ENCTID=$ORDER(^PRCT(446.4,ENCTID))

               if 'ENCTID

                   QUIT 

               DO PUR

TASK       SET X1=DT

           SET X2=1

           DO C^%DTC

           SET ZTIO=""

           SET ZTDTH=X_.01

           SET $PIECE(^($ORDER(^PRCT(446.4,0)),0),"^",8)=X

           SET ZTDESC="BARCODE DATA PURGE"

           SET ZTRTN="^ENCTPRG"

           DO ^%ZTLOAD

           KILL ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN

Q          KILL ENCTID

           QUIT 

PUR        if '$DATA(^PRCT(446.4,ENCTID,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 ENCTNOD=X

 +1        FOR ENCT=0:0

               SET ENCT=$ORDER(^PRCT(446.4,ENCTID,2,"B",ENCT))

               if ENCT>ENCTNOD!'ENCT

                   QUIT 

               FOR ENCTTI=0:0

                   SET ENCTTI=$ORDER(^PRCT(446.4,ENCTID,2,"B",ENCT,ENCTTI))

                   if 'ENCTTI

                       QUIT 

                   SET DA(1)=ENCTID

                   SET DA=ENCTTI

                   SET DIK="^PRCT(446.4,"_ENCTID_",2,"

                   DO ^DIK

 +2        KILL ENCTNOD,ENCTTI,ENCT,DA,DIK

           QUIT