- 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 ---[H[J[2J[HENCTPRG 752 printed Feb 18, 2025@23:18:38 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