ACHSARCH.m

ACHSARCH ; IHS/ITSC/PMF - GENERIC BACKUP/ARCHIEVE UTILITY ; [ 10/31/2003  11:35 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7**;JUNE 11,2001

 ;Y2000 No fix required. Suspected data calculations are for file names

 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify error message; replace data retrieval from non-package global.

 ;ITSC/SET/JVK ACHS*3.1*7 7/21/2003 - Removed mode change for Cache

 Q

 ;

TARBKUP ;EP

 ;;ACHSZFN  = INPUT FILE NAME

 ;;ACHSZDIR = UNIX SUBDIRECTORY LOCATION OF INPUT FILE

 ;;ACHSDTYP =  (Cartridge(C) or Tape (T) - default="C"

 ;

 I '$D(ACHSDTYP) S ACHSDTYP="C"

 I '$D(ACHSZDIR) S ACHSZDIR="/usr/mumps"

 S ACHSDTTP=$S(ACHSDTYP="C":"rct",ACHSDTYP="T":"rmt0")

 S ACHSDNAM=$S(ACHSDTYP="C":"Cartridge Tape",ACHSDTYP="T":"9-Track Tape")

 I '$D(ACHSZFN) G ERROR

 S ACHSFNLN=$L(ACHSZFN)

 U IO(0)

 W !!?10,"Backing up ",ACHSEXFN," to ",ACHSDNAM,!

 S ACHSHCMD="cd "_ACHSZDIR_"; tar -cvft /dev/"_ACHSDTTP_" "_ACHSZFN

 ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 ;of routine in our namespace

 S ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 ;

 U IO(0)

 I ACHSRTCD=0 W !!?10,"Backup to ",ACHSDNAM," was SUCCESSFUL" G TAREXIT

ERROR ;

 W *7,!!?10,"Backup to ",ACHSDNAM," was NOT SUCCESSFUL -- NOTIFY SUPERVISOR"

TAREXIT ;

 S ACHSHCMD="cd /usr/mumps"

 ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 ;of routine in our namespace

 S ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 ;

 G ENDX^ACHSARC1

 ;

ARCHLIST ;EP

 Q:$D(DUOUT)!$D(DTOUT)

 ;;ACHSZFN  =  Input File Name

 ;;ACHSZOPT=0 -- NO Operator Interaction (Default)

 ;;ACHSZOPT=1 -- Ask Operator Questions

 ;;ACHSZDIR = Directory

 I '$D(ACHSZFN) U IO(0) W "FILE NAME ERROR" G ENDX^ACHSARC1

 S ACHSFNLN=$L(ACHSZFN)

 K ACHSJFLG

 I '$D(ACHSZOPT) S ACHSZOPT=0

 S ACHSZFNS=ACHSZFN

 K ACHSFILE

 I '$D(ACHSZDIR) S ACHSZDIR="/usr/mumps/"

 S ACHSDTJL=$E(DT,2,3)_$$JDT^ACHS(DT,1)

 S ACHSHCMD="cd "_ACHSZDIR_"; ls -l "_ACHSZFN_"*"_" | awk '{print $5,$9}' > afs.files"

 ;

 ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 ;of routine in our namespace

 S ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 ;

 S ACHSZFN=ACHSZDIR_$S($E(ACHSZDIR,$L(ACHSZDIR))="/":"",1:"/")_"afs.files",ACHSZZA=0

 ;IHS/JVK/SET ACHS*3.1*7 REMOVE BELOW 

 ;S ACHSZIN=0

 ;

 ;TRY TO OPEN 

 D OPENHFS^ACHSTCK1

 I ACHSZZA D ERROR^ACHSTCK1 G ABEND^ACHSARC1

 S (ACHSFCNT,ACHSDCNT)=0

 F ACHSI=1:1 U ACHSZDEV R ACHSX:1 Q:'$T  Q:$$STATUS^%ZISH  D SUB1

 S ACHSR=0

 G ENDX^ACHSARC1:ACHSZOPT=0

 U IO(0)

 W !!,"NUMBER OF PREVIOUSLY EXPORTED FILES = ",ACHSFCNT

 D SUB2

 I ACHSDCNT>0 G FILEDSP ;IF FILES FOUND LET THEM LIST

 I ACHSDCNT=0 W !,"NO FILES FOUND!" G LISTEND

 U IO(0)

 W !

 S Y=$$DIR^XBDIR("Y","Delete ALL Previously EXPORTED Files Processed BEFORE "_$$FMTE^XLFDT(ACHSDEDT),"Y")

 I Y=1 G FILEDEL

 G:$D(DUOUT)!$D(DTOUT) ARCHLIST

FILEDSP ;

 W !

 K DIR

 S DIR("B")="Y",DIR(0)="Y",DIR("A")="Do you want to LIST Previously EXPORTED FILES?"

 D ^DIR

 G:$D(DUOUT)!$D(DTOUT) ARCHLIST

 I Y'=1 G ENDX^ACHSARC1

A20 ;

 S (ACHSR,ACHSRR,ACHSSEQ)=0

 W !!,"SEQ #  ","# RCDS    EXPORT - DATE  FILE NAME - SFX  OK-TX?  COLOR",!!

FILEDSPA ;

 S ACHSR=$O(ACHSFILE("C",ACHSR))

 G LISTEND:+ACHSR=0

FILEDSPB ;

 S ACHSRR=$O(ACHSFILE("C",ACHSR,ACHSRR))

 G FILEDSPA:+ACHSRR=0

 S ACHSFNAM=$P(ACHSFILE(ACHSRR),U,2),ACHSXPT=0,ACHSXPT=$O(^AFSTXLOG(DUZ(2),1,"B",ACHSFNAM,ACHSXPT))

 ;I +ACHSXPT<1 S ACHSEMSG="ERROR IN TX/EXPORT DATA STRUCTURE  -- NOTIFY SUPERVISOR",ACHSJFLG=1 G JCANCEL^ACHSARC1;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 I +ACHSXPT<1 W !,"No entries for '"_ACHSFNAM_"' for "_$$LOC^ACHS_" in IHS DATA TRANSMISSION LOG file" G FILEDSPB ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 S ACHSTXST="N",$P(ACHSFILE(ACHSRR),U,3)="N"

 ;S:+ACHSXPT>0 ACHSTXST=$P($G(^AFSTXLOG(DUZ(2),1,ACHSXPT,0)),U,4),ACHSHCLR=$P($G(^AFSTXLOG(DUZ(2),1,ACHSXPT,0)),U,5),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 S:+ACHSXPT>0 ACHSTXST=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3,"I"),ACHSHCLR=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3.11),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 ;S ACHSHCLR=$S(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:"");IHS/SET/GTH ACHS*3.1*5 12/06/2002

 S X=$P($P(ACHSFILE(ACHSRR),".",2),U,1)

 S Y=$$GDT^ACHS($E(X,3,5))

 S X=$P(ACHSFILE(ACHSRR),U,1),Z=X/81,X=$J(Z,0,0)

 S ACHSSEQ=ACHSSEQ+1

 W $J(ACHSSEQ,3),?6,$J(X,6),?17,Y

 S Z=$P(ACHSFILE(ACHSRR),U,2)

 S X=$P(Z,".",1)

 W ?33,$E(X,1,ACHSFNLN),?45,$E(X,ACHSFNLN+1,ACHSFNLN+1),?51,ACHSTXST,?57,$S(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:""),!

 G FILEDSPB

 ;

LISTEND ;

 K DIR

 S DIR(0)="E",DIR("A")="Enter RETURN to Continue"

 D ^DIR

 I Y=0 S %="M9",ACHSEMSG=$P($T(@%^ACHSTCK1),";;",2),ACHSJFLG=1 G JCANCEL^ACHSARC1

 G ENDX^ACHSARC1

 ;

SUB1 ;

 S ACHSFCNT=ACHSFCNT+1

 S ACHSFILE(ACHSI)=$P(ACHSX," ",1)_U_$P(ACHSX," ",2),ACHSY=$P($P(ACHSX," ",2),".",2)

 Q:+ACHSY<1

 I '$D(ACHSFILE("C",ACHSY)) S ACHSDCNT=ACHSDCNT+1

 S ACHSFILE("C",99999-ACHSY,ACHSI)=""

 S ACHSZ=$P($P(ACHSX," ",2),"."),ACHSFILE("N",ACHSY,ACHSZ,ACHSI)=""

 Q

 ;

SUB2 ;FIND LATEST DATE OF FILE IN SYSTEM. CHANGE MADE BECAUSE PREVIOUS

 ;CODE COULD NOT HANDLE LESS THAN THREE FILES SAVED OFF

 S ACHSR=0,ACHSLDAT=0

SUB2A F ACHSDCNT=0:1 S ACHSR=$O(ACHSFILE("C",ACHSR)) Q:ACHSR=""  D

 .S ACHSLDAT=99999-ACHSR

 .S ACHSDEDT=$$JTF^ACHS($E(ACHSLDAT,3,5))

 Q

 ;

FILEDEL ;

 S ACHSR=0

 W !

FILEDELA ;

 S ACHSR=$O(ACHSFILE(ACHSR))

 G FILEDEX:+ACHSR=0

 S Z=ACHSFILE(ACHSR)

 S (ACHSXSAV,X)=$P(Z,".",2)

 S ACHSDSAV=$$JTF^ACHS(X)

 I $E(X,1,3)>280,X<ACHSDEDT G ZDEL

 G FILEDELA

 ;

ZDEL ;

 S ACHSFLNM=$P(ACHSFILE(ACHSR),U,2)

 I $$DEL^%ZISH(ACHSZDIR,ACHSFLNM) G FILEDELA

 W !,ACHSFLNM," FILE DELETED"

 K ACHSFILE("C",99999-ACHSXSAV,ACHSR),ACHSFILE("N",ACHSXSAV,$P(ACHSFLNM,".",1),ACHSR),ACHSFILE(ACHSR)

 S ACHSXPT=0,ACHSXPT=$O(^AFSTXLOG(DUZ(2),1,"B",ACHSFLNM,ACHSXPT))

 I +ACHSXPT>0 S DIK="^AFSTXLOG("_DUZ(2)_",1,",DA(1)=DUZ(2),DA=ACHSXPT D ^DIK

 G FILEDELA

 ;

FILEDEX ;

 G ENDX^ACHSARC1

 ;

ACHSARCH  ; IHS/ITSC/PMF - GENERIC BACKUP/ARCHIEVE UTILITY ; [ 10/31/2003  11:35 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,7**;JUNE 11,2001

 +2       ;Y2000 No fix required. Suspected data calculations are for file names

 +3       ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify error message; replace data retrieval from non-package global.

 +4       ;ITSC/SET/JVK ACHS*3.1*7 7/21/2003 - Removed mode change for Cache

 +5        QUIT 

 +6       ;

TARBKUP   ;EP

 +1       ;;ACHSZFN  = INPUT FILE NAME

 +2       ;;ACHSZDIR = UNIX SUBDIRECTORY LOCATION OF INPUT FILE

 +3       ;;ACHSDTYP =  (Cartridge(C) or Tape (T) - default="C"

 +4       ;

 +5        IF '$DATA(ACHSDTYP)

               SET ACHSDTYP="C"

 +6        IF '$DATA(ACHSZDIR)

               SET ACHSZDIR="/usr/mumps"

 +7        SET ACHSDTTP=$SELECT(ACHSDTYP="C":"rct",ACHSDTYP="T":"rmt0")

 +8        SET ACHSDNAM=$SELECT(ACHSDTYP="C":"Cartridge Tape",ACHSDTYP="T":"9-Track Tape")

 +9        IF '$DATA(ACHSZFN)

               GOTO ERROR

 +10       SET ACHSFNLN=$LENGTH(ACHSZFN)

 +11       USE IO(0)

 +12       WRITE !!?10,"Backing up ",ACHSEXFN," to ",ACHSDNAM,!

 +13       SET ACHSHCMD="cd "_ACHSZDIR_"; tar -cvft /dev/"_ACHSDTTP_" "_ACHSZFN

 +14      ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 +15      ;of routine in our namespace

 +16       SET ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 +17      ;

 +18       USE IO(0)

 +19       IF ACHSRTCD=0

               WRITE !!?10,"Backup to ",ACHSDNAM," was SUCCESSFUL"

               GOTO TAREXIT

ERROR     ;

 +1        WRITE *7,!!?10,"Backup to ",ACHSDNAM," was NOT SUCCESSFUL -- NOTIFY SUPERVISOR"

TAREXIT   ;

 +1        SET ACHSHCMD="cd /usr/mumps"

 +2       ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 +3       ;of routine in our namespace

 +4        SET ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 +5       ;

 +6        GOTO ENDX^ACHSARC1

 +7       ;

ARCHLIST  ;EP

 +1        IF $DATA(DUOUT)!$DATA(DTOUT)

               QUIT 

 +2       ;;ACHSZFN  =  Input File Name

 +3       ;;ACHSZOPT=0 -- NO Operator Interaction (Default)

 +4       ;;ACHSZOPT=1 -- Ask Operator Questions

 +5       ;;ACHSZDIR = Directory

 +6        IF '$DATA(ACHSZFN)

               USE IO(0)

               WRITE "FILE NAME ERROR"

               GOTO ENDX^ACHSARC1

 +7        SET ACHSFNLN=$LENGTH(ACHSZFN)

 +8        KILL ACHSJFLG

 +9        IF '$DATA(ACHSZOPT)

               SET ACHSZOPT=0

 +10       SET ACHSZFNS=ACHSZFN

 +11       KILL ACHSFILE

 +12       IF '$DATA(ACHSZDIR)

               SET ACHSZDIR="/usr/mumps/"

 +13       SET ACHSDTJL=$EXTRACT(DT,2,3)_$$JDT^ACHS(DT,1)

 +14       SET ACHSHCMD="cd "_ACHSZDIR_"; ls -l "_ACHSZFN_"*"_" | awk '{print $5,$9}' > afs.files"

 +15      ;

 +16      ;IHSIHS/ITSC/PMF  1/12/01  change call of vendor routine to call

 +17      ;of routine in our namespace

 +18       SET ACHSRTCD=$$TERMINAL^ACHSHCMD(ACHSHCMD)

 +19      ;

 +20       SET ACHSZFN=ACHSZDIR_$SELECT($EXTRACT(ACHSZDIR,$LENGTH(ACHSZDIR))="/":"",1:"/")_"afs.files"

           SET ACHSZZA=0

 +21      ;IHS/JVK/SET ACHS*3.1*7 REMOVE BELOW 

 +22      ;S ACHSZIN=0

 +23      ;

 +24      ;TRY TO OPEN 

 +25       DO OPENHFS^ACHSTCK1

 +26       IF ACHSZZA

               DO ERROR^ACHSTCK1

               GOTO ABEND^ACHSARC1

 +27       SET (ACHSFCNT,ACHSDCNT)=0

 +28       FOR ACHSI=1:1

               USE ACHSZDEV

               READ ACHSX:1

               IF '$TEST

                   QUIT 

               IF $$STATUS^%ZISH

                   QUIT 

               DO SUB1

 +29       SET ACHSR=0

 +30       IF ACHSZOPT=0

               GOTO ENDX^ACHSARC1

 +31       USE IO(0)

 +32       WRITE !!,"NUMBER OF PREVIOUSLY EXPORTED FILES = ",ACHSFCNT

 +33       DO SUB2

 +34      ;IF FILES FOUND LET THEM LIST

           IF ACHSDCNT>0

               GOTO FILEDSP

 +35       IF ACHSDCNT=0

               WRITE !,"NO FILES FOUND!"

               GOTO LISTEND

 +36       USE IO(0)

 +37       WRITE !

 +38       SET Y=$$DIR^XBDIR("Y","Delete ALL Previously EXPORTED Files Processed BEFORE "_$$FMTE^XLFDT(ACHSDEDT),"Y")

 +39       IF Y=1

               GOTO FILEDEL

 +40       IF $DATA(DUOUT)!$DATA(DTOUT)

               GOTO ARCHLIST

FILEDSP   ;

 +1        WRITE !

 +2        KILL DIR

 +3        SET DIR("B")="Y"

           SET DIR(0)="Y"

           SET DIR("A")="Do you want to LIST Previously EXPORTED FILES?"

 +4        DO ^DIR

 +5        IF $DATA(DUOUT)!$DATA(DTOUT)

               GOTO ARCHLIST

 +6        IF Y'=1

               GOTO ENDX^ACHSARC1

A20       ;

 +1        SET (ACHSR,ACHSRR,ACHSSEQ)=0

 +2        WRITE !!,"SEQ #  ","# RCDS    EXPORT - DATE  FILE NAME - SFX  OK-TX?  COLOR",!!

FILEDSPA  ;

 +1        SET ACHSR=$ORDER(ACHSFILE("C",ACHSR))

 +2        IF +ACHSR=0

               GOTO LISTEND

FILEDSPB  ;

 +1        SET ACHSRR=$ORDER(ACHSFILE("C",ACHSR,ACHSRR))

 +2        IF +ACHSRR=0

               GOTO FILEDSPA

 +3        SET ACHSFNAM=$PIECE(ACHSFILE(ACHSRR),U,2)

           SET ACHSXPT=0

           SET ACHSXPT=$ORDER(^AFSTXLOG(DUZ(2),1,"B",ACHSFNAM,ACHSXPT))

 +4       ;I +ACHSXPT<1 S ACHSEMSG="ERROR IN TX/EXPORT DATA STRUCTURE  -- NOTIFY SUPERVISOR",ACHSJFLG=1 G JCANCEL^ACHSARC1;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +5       ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           IF +ACHSXPT<1

               WRITE !,"No entries for '"_ACHSFNAM_"' for "_$$LOC^ACHS_" in IHS DATA TRANSMISSION LOG file"

               GOTO FILEDSPB

 +6        SET ACHSTXST="N"

           SET $PIECE(ACHSFILE(ACHSRR),U,3)="N"

 +7       ;S:+ACHSXPT>0 ACHSTXST=$P($G(^AFSTXLOG(DUZ(2),1,ACHSXPT,0)),U,4),ACHSHCLR=$P($G(^AFSTXLOG(DUZ(2),1,ACHSXPT,0)),U,5),$P(ACHSFILE(ACHSRR),U,3)=ACHSTXST;IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +8       ;IHS/SET/GTH ACHS*3.1*5 12/06/2002

           IF +ACHSXPT>0

               SET ACHSTXST=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3,"I")

               SET ACHSHCLR=$$GET1^DIQ(9002320.52,ACHSXPT_","_DUZ(2)_",",3.11)

               SET $PIECE(ACHSFILE(ACHSRR),U,3)=ACHSTXST

 +9       ;S ACHSHCLR=$S(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:"");IHS/SET/GTH ACHS*3.1*5 12/06/2002

 +10       SET X=$PIECE($PIECE(ACHSFILE(ACHSRR),".",2),U,1)

 +11       SET Y=$$GDT^ACHS($EXTRACT(X,3,5))

 +12       SET X=$PIECE(ACHSFILE(ACHSRR),U,1)

           SET Z=X/81

           SET X=$JUSTIFY(Z,0,0)

 +13       SET ACHSSEQ=ACHSSEQ+1

 +14       WRITE $JUSTIFY(ACHSSEQ,3),?6,$JUSTIFY(X,6),?17,Y

 +15       SET Z=$PIECE(ACHSFILE(ACHSRR),U,2)

 +16       SET X=$PIECE(Z,".",1)

 +17       WRITE ?33,$EXTRACT(X,1,ACHSFNLN),?45,$EXTRACT(X,ACHSFNLN+1,ACHSFNLN+1),?51,ACHSTXST,?57,$SELECT(ACHSHCLR="R":"RED",ACHSHCLR="B":"BLUE",1:""),!

 +18       GOTO FILEDSPB

 +19      ;

LISTEND   ;

 +1        KILL DIR

 +2        SET DIR(0)="E"

           SET DIR("A")="Enter RETURN to Continue"

 +3        DO ^DIR

 +4        IF Y=0

               SET %="M9"

               SET ACHSEMSG=$PIECE($TEXT(@%^ACHSTCK1),";;",2)

               SET ACHSJFLG=1

               GOTO JCANCEL^ACHSARC1

 +5        GOTO ENDX^ACHSARC1

 +6       ;

SUB1      ;

 +1        SET ACHSFCNT=ACHSFCNT+1

 +2        SET ACHSFILE(ACHSI)=$PIECE(ACHSX," ",1)_U_$PIECE(ACHSX," ",2)

           SET ACHSY=$PIECE($PIECE(ACHSX," ",2),".",2)

 +3        IF +ACHSY<1

               QUIT 

 +4        IF '$DATA(ACHSFILE("C",ACHSY))

               SET ACHSDCNT=ACHSDCNT+1

 +5        SET ACHSFILE("C",99999-ACHSY,ACHSI)=""

 +6        SET ACHSZ=$PIECE($PIECE(ACHSX," ",2),".")

           SET ACHSFILE("N",ACHSY,ACHSZ,ACHSI)=""

 +7        QUIT 

 +8       ;

SUB2      ;FIND LATEST DATE OF FILE IN SYSTEM. CHANGE MADE BECAUSE PREVIOUS

 +1       ;CODE COULD NOT HANDLE LESS THAN THREE FILES SAVED OFF

 +2        SET ACHSR=0

           SET ACHSLDAT=0

SUB2A      FOR ACHSDCNT=0:1

               SET ACHSR=$ORDER(ACHSFILE("C",ACHSR))

               IF ACHSR=""

                   QUIT 

               Begin DoDot:1

 +1                SET ACHSLDAT=99999-ACHSR

 +2                SET ACHSDEDT=$$JTF^ACHS($EXTRACT(ACHSLDAT,3,5))

               End DoDot:1

 +3        QUIT 

 +4       ;

FILEDEL   ;

 +1        SET ACHSR=0

 +2        WRITE !

FILEDELA  ;

 +1        SET ACHSR=$ORDER(ACHSFILE(ACHSR))

 +2        IF +ACHSR=0

               GOTO FILEDEX

 +3        SET Z=ACHSFILE(ACHSR)

 +4        SET (ACHSXSAV,X)=$PIECE(Z,".",2)

 +5        SET ACHSDSAV=$$JTF^ACHS(X)

 +6        IF $EXTRACT(X,1,3)>280

               IF X<ACHSDEDT

                   GOTO ZDEL

 +7        GOTO FILEDELA

 +8       ;

ZDEL      ;

 +1        SET ACHSFLNM=$PIECE(ACHSFILE(ACHSR),U,2)

 +2        IF $$DEL^%ZISH(ACHSZDIR,ACHSFLNM)

               GOTO FILEDELA

 +3        WRITE !,ACHSFLNM," FILE DELETED"

 +4        KILL ACHSFILE("C",99999-ACHSXSAV,ACHSR),ACHSFILE("N",ACHSXSAV,$PIECE(ACHSFLNM,".",1),ACHSR),ACHSFILE(ACHSR)

 +5        SET ACHSXPT=0

           SET ACHSXPT=$ORDER(^AFSTXLOG(DUZ(2),1,"B",ACHSFLNM,ACHSXPT))

 +6        IF +ACHSXPT>0

               SET DIK="^AFSTXLOG("_DUZ(2)_",1,"

               SET DA(1)=DUZ(2)

               SET DA=ACHSXPT

               DO ^DIK

 +7        GOTO FILEDELA

 +8       ;

FILEDEX   ;

 +1        GOTO ENDX^ACHSARC1

 +2       ;