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 ;