- 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 ;