AFSHEX1 ;IHS/OIRM/DSD/JDM-DHR SPLITOUT PROGRAM #2; [ 10/27/2004 4:20 PM ]
;;3.0T1;AO FINANCIAL DATA MGMT SYSTEM;**2,16,13**;FEB 02, 1999
;;MODIFICATIONS ARE MADE FOR CACHE' COMPLIANCE; ACR*2.1*9
A0 D ^XBCLS K AFSJFLG
F I=1:1:70 W "*"
W !,?10,"D H R S P L I T - O U T I N P R O C E S S",!
F I=1:1:70 W "*"
W !
S AFSHPHDR(1)="LISTING OF INDIVIDUAL RECORDS",AFSHPHDR(2)="DHR BATCH RECONCILIATION TABLE",AFSHPGNO=0,AFSHBTCT=0,AFSHPLCT=0,AFSHRPT=1,AFSHTRCT=0 K AFSHBTNM
A0B ;D PTRDEF^AFSTUT4 Q:$D(AFSJFLG)
;D PTRSEL^AFSTUT4 Q:$D(AFSJFLG)
S %ZIS("A")="What PRINTER do you want to use? "
D ^%ZIS
G Q:POP
U IO(0) W !
;I IO>0 S AFSHPTRD=IO ;ACR*2.1*13.01 IM13574
Q:IO']"" S AFSHPTRD=IO ;ACR*2.1*13.01 IM13574
D PTRHDR^AFSHEX2
A0C S X=$P(^AUTTLOC(DUZ(2),0),U,4),AFSHCNPF=$P(^AUTTAREA(X,0),U,4),AFSHAREA=$P(^(0),U,1),AFSHAPN=$P(^AUTTSITE(1,0),U,2)
I $E(AFSHCNPF,1,1)'="J"!($L(AFSHAREA)<3)!(+AFSHAPN'>0) S AFSERMSG="ACCOUNTING INFORMATION MISSING" G JCANCEL^AFSHEX1A
S AFSHDEST=AFSCCTR
D NOW^%DTC S AFSHNOW=% S $P(^AFSHRCDS(AFSHBCLR,0),U,2)=AFSHNOW
;K ^AFSHTEMP ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed ;ACR*2.1*13.02 IM13574
N AFSKIL S AFSKIL="^AFSHTEMP" ; ACR*2.1*13.02 IM13574
K @AFSKIL ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed ;ACR*2.1*13.02 IM13574
K ^TMP("ACR",$J,"EXP")
B0 S AFSR=AFSHBCLR,(AFSRR,AFSRRR,AFSRRRR)=0
B1 S AFSRR=$O(^AFSHRCDS(AFSR,"D","B",AFSRR)) G ZEND:+AFSRR=0
B2 S AFSRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR)) G B1:AFSRRR=""
S AFSRRRP=0,AFSRRRP=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR,AFSRRRP))
S AFSRRA=$P(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,0),U,1),AFSHBCNT=$P(^(0),U,5),AFSHBTOT=$P(^(0),U,6),AFSHBAP=$P(^(0),U,2)
S AFSHBDAT=AFSRR D PCCHDR^AFSHEX1A
S AFSRRRR=0
B3 S AFSRRRR=$O(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR)) G BTRL:+AFSRRRR=0
S AFSHYY=^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,0)
I AFSRRRR#100=0 U IO(0) W $J(AFSRRRR,8)
D ^AFSHEX2
S AFSHTRCT=AFSHTRCT+2,AFSHPLCT=AFSHPLCT+2
S ACRFMS=$G(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,99))
I $G(ACRFMS) S ^TMP("ACR",$J,"EXP",ACRFMS)=AFSR_U_AFSRR_U_AFSRRR_U_AFSRRRR
G B3
BTRL D PCCTRL^AFSHEX1A
G B2
ZEND ;EXIT POINT FROM $O -- DO NOT DELETE
I AFSHPLCT>55 D PTRHDR^AFSHEX2
S AFSJCLNO=8 S:AFSCCTR="BCS" AFSJCLNO=10
U AFSHPTRD W !!,?10,"NUMBER OF OUTPUT DHR RECORDS = ",?45,$J(AFSHTRCT,8),!!,?10,"NUMBER OF JCL RECORDS = ",?45,$J(AFSJCLNO,8),!!
S X="",$P(X,"-",44)="" W ?10,X,!,?15,"TOTAL RECORDS TO TRANSMIT = ",?45,$J(AFSHTRCT+AFSJCLNO,8),!!
REPORT2 ;
S AFSHRPT=2,AFSHTOT1=0,AFSHTOT2=0
D PTRHDR^AFSHEX2
REP0 S AFSR=0,AFSSPACE="",$P(AFSSPACE," ",41)=""
REP1 S AFSR=$O(AFSHBTNM(AFSR)) G REPEND:AFSR=""
S X=AFSHBTNM(AFSR),Y=$P(X,U,1)
S AFSHPTRL=$E(AFSSPACE,1,35)_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "_$P(X,U,2)_$E(AFSSPACE,1,20)_$J($P(X,U,3),4)
S AFSHPLCT=AFSHPLCT+2
S AFSHTOT1=AFSHTOT1+1,AFSHTOT2=AFSHTOT2+$P(X,U,3)
D PTRWRITE^AFSHEX2 S AFSHPTRL="" D PTRWRITE^AFSHEX2
G REP1
REPEND S AFSHPTRL="" D PTRWRITE^AFSHEX2
S AFSHPTRL=$E(AFSSPACE,1,30)_"TOTAL "_$J(AFSHTOT1,4)_$E(AFSSPACE,1,20)_$J(AFSHTOT2,7) D PTRWRITE^AFSHEX2
;I $D(AFSHPTRD)&('$D(^AFSHPARM(DUZ(2),0))!($P(^AFSHPARM(DUZ(2),0),U,5)["N")) S IO=AFSHPTRD D ^%ZISC ;LINE CHGED FOR 1166 POSTING ;ACR*2.1*13.02 IM13574
I $D(AFSHPTRD),('$D(^AFSHPARM(DUZ(2),0))!($P(^AFSHPARM(DUZ(2),0),U,5)["N")) D ^%ZISC ;ACR*2.1*13.02 IM13574
;I $D(%DEV) S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
I $D(%DEV) D CLOSE^%ZISH() ;ACR*2.1*13.02 IM13574
;L ;ACR*2.1*13.02 IM13574
FILECPY ;;COPY ^AFSHTEMP GLOBAL TO PCC & BCS UNIX FILES
S (AFSFLNM1,AFSFLNM2)="",AFSRCNT=0
I AFSHDTNM="DHRP"!(AFSHDTNM="dhp") G FCOPYA
S AFSHDTNM="dhc",AFSCCTR="PCC",AFSPKGNM="ACHS"
FCOPYA ;
I $D(AFSHDTNM) S AFSZSAV=AFSHDTNM ;AFSH*3.0T1*2
D FILESEL^AFSEXUT0 I $D(AFSJFLG) G ENDERR^AFSHEX0A
I $D(AFSZSAV) S AFSHDTNM=AFSZSAV ;AFSH*3.0T1*2
K AFSZSAV ;AFSH*3.0T1*2
S AFSFLNM1=AFSEXFN
S %FN=AFSEXFN,%IN=0 D OPENHFS^AFSTCK1 I %ZA<0 D ERROR^AFSTCK1 S AFSERMSG="JOB PROCESSING ERROR" G JCANCEL^AFSHEX1A
D PCCJHDR^AFSHEX1A
U IO(0) W !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
D COPY2
D PCCJTRL^AFSHEX1A
;S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
D CLOSE^%ZISH() ;ACR*2.1*13.02 IM13574
S AFSJCLCT(1)=AFSRCNT+AFSZCNT
D LINK(AFSEXFN)
I AFSHDTNM="DHRP"!(AFSHDTNM="dhp") G LOG1
S AFSHDTNM="bhc",AFSCCTR="BCS",AFSPKGNM="ACHS"
D FILESEL^AFSEXUT0 I $D(AFSJFLG) G ENDERR^AFSHEX0A
K %DEV S AFSRCNT=0
S AFSFLNM2=AFSEXFN
S %FN=AFSEXFN,%IN=0 D OPENHFS^AFSTCK1 I %ZA<0 D ERROR^AFSTCK1 S AFSERMSG="JOB PROCESSING ERROR" G JCANCEL^AFSHEX1A
D FIJHDR^AFSHEX1A
U IO(0) W !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
D COPY2
D FIJTRL^AFSHEX1A
;S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
D CLOSE^%ZISH() ;ACR*2.1*13.02 IM13574
S AFSJCLCT(2)=AFSRCNT+AFSZCNT
D LINK(AFSEXFN)
LOG1 S AFSEXFNS=$P(AFSFLNM1,"/",5) D TXLOGADD^AFSTXUT0
I +AFSY<0 U IO(0) W "IHS TX LOG POSTING ERROR" G JCANCEL^AFSHEX1A
S AFSRCNT=AFSJCLCT(1)
I +AFSY D NORMEND^AFSTUT5
I AFSFLNM2="" G BKUP
S AFSEXFNS=$P(AFSFLNM2,"/",5) D TXLOGADD^AFSTXUT0
I +AFSY<0 U IO(0) W "IHS TX LOG POSTING ERROR" G JCANCEL^AFSHEX1A
S AFSRCNT=AFSJCLCT(2)
I +AFSY D NORMEND^AFSTUT5
; DO BACKUP HERE
BKUP K AFSJFLG S AFSRTCD=999
I '$D(AFSHPARM(DUZ(2))) G BKUPA
I $P(^AFSHPARM(DUZ(2)),U,4)="N" G BKUPOK
BKUPA S %SDIR="",%FN=AFSFLNM1_" "_AFSFLNM2,AFSDTYPE="C",AFSEXFN="DHR TX FILES" D TARBKUP^AFSARCH0
I AFSRTCD=0 G BKUPOK
K DIR S DIR("A")="Do you want to try BACKUP file to "_AFSDNAME_" AGAIN?",DIR("B")="Y",DIR(0)="Y" D ^DIR
I Y=0 S AFSJFLG=1 Q
W !!,*7,"Make sure an appropriate TAPE (Write Enabled) is in the ",AFSDNAME," DRIVE",!
K DIR S DIR(0)="E" D ^DIR
I Y=0 S AFSJFLG=1 G ENDERR^AFSHEX0A
G BKUP
BKUPOK Q
COPY2 ;;SUBROUTINE TO COPY TX DATA FROM GLOBAL TO EXT FILE
S AFSGCNT=0,AFSZCNT=0
COPY2A S AFSGCNT=$O(^AFSHTEMP(AFSGCNT)) G COPY2END:AFSGCNT=""
S AFSDATA=^AFSHTEMP(AFSGCNT) U %DEV W AFSDATA,!
I AFSGCNT#100=0 U IO(0) W $J(AFSGCNT,8)
S AFSZCNT=AFSZCNT+1
G COPY2A
COPY2END Q
Q ;
D ^%ZISC
Q
LINK(X7) ;----- FMS DOCUMENT HISTORY RECORD FILE LINK
; NEW SUBROUTINE ACR*2.0T1*16
;
; X7 = UNIX TRANSMISSION FILE
;
N ACRFMS,X,X3,X4,X5,X6
Q:'$D(^TMP("ACR",$J,"EXP"))
S X7=$P(AFSEXFN,"/",$L(AFSEXFN,"/"))
S ACRFMS=0
F S ACRFMS=$O(^TMP("ACR",$J,"EXP",ACRFMS)) Q:'ACRFMS D
. S X=^TMP("ACR",$J,"EXP",ACRFMS)
. S X3=$P(X,U)
. S X4=$P(X,U,2)
. S X5=$P(X,U,3)
. S X6=$P(X,U,4)
. D LINK^ACRFDHRE(ACRFMS,DT,X3,X4,X5,X6,X7)
K ^TMP("ACR",$J,"EXP")
Q
AFSHEX1 ;IHS/OIRM/DSD/JDM-DHR SPLITOUT PROGRAM #2; [ 10/27/2004 4:20 PM ]
+1 ;;3.0T1;AO FINANCIAL DATA MGMT SYSTEM;**2,16,13**;FEB 02, 1999
+2 ;;MODIFICATIONS ARE MADE FOR CACHE' COMPLIANCE; ACR*2.1*9
A0 DO ^XBCLS
KILL AFSJFLG
+1 FOR I=1:1:70
WRITE "*"
+2 WRITE !,?10,"D H R S P L I T - O U T I N P R O C E S S",!
+3 FOR I=1:1:70
WRITE "*"
+4 WRITE !
+5 SET AFSHPHDR(1)="LISTING OF INDIVIDUAL RECORDS"
SET AFSHPHDR(2)="DHR BATCH RECONCILIATION TABLE"
SET AFSHPGNO=0
SET AFSHBTCT=0
SET AFSHPLCT=0
SET AFSHRPT=1
SET AFSHTRCT=0
KILL AFSHBTNM
A0B ;D PTRDEF^AFSTUT4 Q:$D(AFSJFLG)
+1 ;D PTRSEL^AFSTUT4 Q:$D(AFSJFLG)
+2 SET %ZIS("A")="What PRINTER do you want to use? "
+3 DO ^%ZIS
+4 IF POP
GOTO Q
+5 USE IO(0)
WRITE !
+6 ;I IO>0 S AFSHPTRD=IO ;ACR*2.1*13.01 IM13574
+7 ;ACR*2.1*13.01 IM13574
IF IO']""
QUIT
SET AFSHPTRD=IO
+8 DO PTRHDR^AFSHEX2
A0C SET X=$PIECE(^AUTTLOC(DUZ(2),0),U,4)
SET AFSHCNPF=$PIECE(^AUTTAREA(X,0),U,4)
SET AFSHAREA=$PIECE(^(0),U,1)
SET AFSHAPN=$PIECE(^AUTTSITE(1,0),U,2)
+1 IF $EXTRACT(AFSHCNPF,1,1)'="J"!($LENGTH(AFSHAREA)<3)!(+AFSHAPN'>0)
SET AFSERMSG="ACCOUNTING INFORMATION MISSING"
GOTO JCANCEL^AFSHEX1A
+2 SET AFSHDEST=AFSCCTR
+3 DO NOW^%DTC
SET AFSHNOW=%
SET $PIECE(^AFSHRCDS(AFSHBCLR,0),U,2)=AFSHNOW
+4 ;K ^AFSHTEMP ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed ;ACR*2.1*13.02 IM13574
+5 ; ACR*2.1*13.02 IM13574
NEW AFSKIL
SET AFSKIL="^AFSHTEMP"
+6 ; SCRATCH GLOBAL FOR TX DATA TO EXT FILE killed ;ACR*2.1*13.02 IM13574
KILL @AFSKIL
+7 KILL ^TMP("ACR",$JOB,"EXP")
B0 SET AFSR=AFSHBCLR
SET (AFSRR,AFSRRR,AFSRRRR)=0
B1 SET AFSRR=$ORDER(^AFSHRCDS(AFSR,"D","B",AFSRR))
IF +AFSRR=0
GOTO ZEND
B2 SET AFSRRR=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR))
IF AFSRRR=""
GOTO B1
+1 SET AFSRRRP=0
SET AFSRRRP=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I","B",AFSRRR,AFSRRRP))
+2 SET AFSRRA=$PIECE(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,0),U,1)
SET AFSHBCNT=$PIECE(^(0),U,5)
SET AFSHBTOT=$PIECE(^(0),U,6)
SET AFSHBAP=$PIECE(^(0),U,2)
+3 SET AFSHBDAT=AFSRR
DO PCCHDR^AFSHEX1A
+4 SET AFSRRRR=0
B3 SET AFSRRRR=$ORDER(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR))
IF +AFSRRRR=0
GOTO BTRL
+1 SET AFSHYY=^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,0)
+2 IF AFSRRRR#100=0
USE IO(0)
WRITE $JUSTIFY(AFSRRRR,8)
+3 DO ^AFSHEX2
+4 SET AFSHTRCT=AFSHTRCT+2
SET AFSHPLCT=AFSHPLCT+2
+5 SET ACRFMS=$GET(^AFSHRCDS(AFSR,"D",AFSRR,"I",AFSRRRP,"S",AFSRRRR,99))
+6 IF $GET(ACRFMS)
SET ^TMP("ACR",$JOB,"EXP",ACRFMS)=AFSR_U_AFSRR_U_AFSRRR_U_AFSRRRR
+7 GOTO B3
BTRL DO PCCTRL^AFSHEX1A
+1 GOTO B2
ZEND ;EXIT POINT FROM $O -- DO NOT DELETE
+1 IF AFSHPLCT>55
DO PTRHDR^AFSHEX2
+2 SET AFSJCLNO=8
IF AFSCCTR="BCS"
SET AFSJCLNO=10
+3 USE AFSHPTRD
WRITE !!,?10,"NUMBER OF OUTPUT DHR RECORDS = ",?45,$JUSTIFY(AFSHTRCT,8),!!,?10,"NUMBER OF JCL RECORDS = ",?45,$JUSTIFY(AFSJCLNO,8),!!
+4 SET X=""
SET $PIECE(X,"-",44)=""
WRITE ?10,X,!,?15,"TOTAL RECORDS TO TRANSMIT = ",?45,$JUSTIFY(AFSHTRCT+AFSJCLNO,8),!!
REPORT2 ;
+1 SET AFSHRPT=2
SET AFSHTOT1=0
SET AFSHTOT2=0
+2 DO PTRHDR^AFSHEX2
REP0 SET AFSR=0
SET AFSSPACE=""
SET $PIECE(AFSSPACE," ",41)=""
REP1 SET AFSR=$ORDER(AFSHBTNM(AFSR))
IF AFSR=""
GOTO REPEND
+1 SET X=AFSHBTNM(AFSR)
SET Y=$PIECE(X,U,1)
+2 SET AFSHPTRL=$EXTRACT(AFSSPACE,1,35)_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "_$PIECE(X,U,2)_$EXTRACT(AFSSPACE,1,20)_$JUSTIFY($PIECE(X,U,3),4)
+3 SET AFSHPLCT=AFSHPLCT+2
+4 SET AFSHTOT1=AFSHTOT1+1
SET AFSHTOT2=AFSHTOT2+$PIECE(X,U,3)
+5 DO PTRWRITE^AFSHEX2
SET AFSHPTRL=""
DO PTRWRITE^AFSHEX2
+6 GOTO REP1
REPEND SET AFSHPTRL=""
DO PTRWRITE^AFSHEX2
+1 SET AFSHPTRL=$EXTRACT(AFSSPACE,1,30)_"TOTAL "_$JUSTIFY(AFSHTOT1,4)_$EXTRACT(AFSSPACE,1,20)_$JUSTIFY(AFSHTOT2,7)
DO PTRWRITE^AFSHEX2
+2 ;I $D(AFSHPTRD)&('$D(^AFSHPARM(DUZ(2),0))!($P(^AFSHPARM(DUZ(2),0),U,5)["N")) S IO=AFSHPTRD D ^%ZISC ;LINE CHGED FOR 1166 POSTING ;ACR*2.1*13.02 IM13574
+3 ;ACR*2.1*13.02 IM13574
IF $DATA(AFSHPTRD)
IF ('$DATA(^AFSHPARM(DUZ(2),0))!($PIECE(^AFSHPARM(DUZ(2),0),U,5)["N"))
DO ^%ZISC
+4 ;I $D(%DEV) S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
+5 ;ACR*2.1*13.02 IM13574
IF $DATA(%DEV)
DO CLOSE^%ZISH()
+6 ;L ;ACR*2.1*13.02 IM13574
FILECPY ;;COPY ^AFSHTEMP GLOBAL TO PCC & BCS UNIX FILES
+1 SET (AFSFLNM1,AFSFLNM2)=""
SET AFSRCNT=0
+2 IF AFSHDTNM="DHRP"!(AFSHDTNM="dhp")
GOTO FCOPYA
+3 SET AFSHDTNM="dhc"
SET AFSCCTR="PCC"
SET AFSPKGNM="ACHS"
FCOPYA ;
+1 ;AFSH*3.0T1*2
IF $DATA(AFSHDTNM)
SET AFSZSAV=AFSHDTNM
+2 DO FILESEL^AFSEXUT0
IF $DATA(AFSJFLG)
GOTO ENDERR^AFSHEX0A
+3 ;AFSH*3.0T1*2
IF $DATA(AFSZSAV)
SET AFSHDTNM=AFSZSAV
+4 ;AFSH*3.0T1*2
KILL AFSZSAV
+5 SET AFSFLNM1=AFSEXFN
+6 SET %FN=AFSEXFN
SET %IN=0
DO OPENHFS^AFSTCK1
IF %ZA<0
DO ERROR^AFSTCK1
SET AFSERMSG="JOB PROCESSING ERROR"
GOTO JCANCEL^AFSHEX1A
+7 DO PCCJHDR^AFSHEX1A
+8 USE IO(0)
WRITE !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
+9 DO COPY2
+10 DO PCCJTRL^AFSHEX1A
+11 ;S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
+12 ;ACR*2.1*13.02 IM13574
DO CLOSE^%ZISH()
+13 SET AFSJCLCT(1)=AFSRCNT+AFSZCNT
+14 DO LINK(AFSEXFN)
+15 IF AFSHDTNM="DHRP"!(AFSHDTNM="dhp")
GOTO LOG1
+16 SET AFSHDTNM="bhc"
SET AFSCCTR="BCS"
SET AFSPKGNM="ACHS"
+17 DO FILESEL^AFSEXUT0
IF $DATA(AFSJFLG)
GOTO ENDERR^AFSHEX0A
+18 KILL %DEV
SET AFSRCNT=0
+19 SET AFSFLNM2=AFSEXFN
+20 SET %FN=AFSEXFN
SET %IN=0
DO OPENHFS^AFSTCK1
IF %ZA<0
DO ERROR^AFSTCK1
SET AFSERMSG="JOB PROCESSING ERROR"
GOTO JCANCEL^AFSHEX1A
+21 DO FIJHDR^AFSHEX1A
+22 USE IO(0)
WRITE !!,?10,"COPYING DHR DATA TO ",AFSEXFN,!!
+23 DO COPY2
+24 DO FIJTRL^AFSHEX1A
+25 ;S IO=%DEV D ^%ZISC ;ACR*2.1*13.02 IM13574
+26 ;ACR*2.1*13.02 IM13574
DO CLOSE^%ZISH()
+27 SET AFSJCLCT(2)=AFSRCNT+AFSZCNT
+28 DO LINK(AFSEXFN)
LOG1 SET AFSEXFNS=$PIECE(AFSFLNM1,"/",5)
DO TXLOGADD^AFSTXUT0
+1 IF +AFSY<0
USE IO(0)
WRITE "IHS TX LOG POSTING ERROR"
GOTO JCANCEL^AFSHEX1A
+2 SET AFSRCNT=AFSJCLCT(1)
+3 IF +AFSY
DO NORMEND^AFSTUT5
+4 IF AFSFLNM2=""
GOTO BKUP
+5 SET AFSEXFNS=$PIECE(AFSFLNM2,"/",5)
DO TXLOGADD^AFSTXUT0
+6 IF +AFSY<0
USE IO(0)
WRITE "IHS TX LOG POSTING ERROR"
GOTO JCANCEL^AFSHEX1A
+7 SET AFSRCNT=AFSJCLCT(2)
+8 IF +AFSY
DO NORMEND^AFSTUT5
+9 ; DO BACKUP HERE
BKUP KILL AFSJFLG
SET AFSRTCD=999
+1 IF '$DATA(AFSHPARM(DUZ(2)))
GOTO BKUPA
+2 IF $PIECE(^AFSHPARM(DUZ(2)),U,4)="N"
GOTO BKUPOK
BKUPA SET %SDIR=""
SET %FN=AFSFLNM1_" "_AFSFLNM2
SET AFSDTYPE="C"
SET AFSEXFN="DHR TX FILES"
DO TARBKUP^AFSARCH0
+1 IF AFSRTCD=0
GOTO BKUPOK
+2 KILL DIR
SET DIR("A")="Do you want to try BACKUP file to "_AFSDNAME_" AGAIN?"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
+3 IF Y=0
SET AFSJFLG=1
QUIT
+4 WRITE !!,*7,"Make sure an appropriate TAPE (Write Enabled) is in the ",AFSDNAME," DRIVE",!
+5 KILL DIR
SET DIR(0)="E"
DO ^DIR
+6 IF Y=0
SET AFSJFLG=1
GOTO ENDERR^AFSHEX0A
+7 GOTO BKUP
BKUPOK QUIT
COPY2 ;;SUBROUTINE TO COPY TX DATA FROM GLOBAL TO EXT FILE
+1 SET AFSGCNT=0
SET AFSZCNT=0
COPY2A SET AFSGCNT=$ORDER(^AFSHTEMP(AFSGCNT))
IF AFSGCNT=""
GOTO COPY2END
+1 SET AFSDATA=^AFSHTEMP(AFSGCNT)
USE %DEV
WRITE AFSDATA,!
+2 IF AFSGCNT#100=0
USE IO(0)
WRITE $JUSTIFY(AFSGCNT,8)
+3 SET AFSZCNT=AFSZCNT+1
+4 GOTO COPY2A
COPY2END QUIT
Q ;
+1 DO ^%ZISC
+2 QUIT
LINK(X7) ;----- FMS DOCUMENT HISTORY RECORD FILE LINK
+1 ; NEW SUBROUTINE ACR*2.0T1*16
+2 ;
+3 ; X7 = UNIX TRANSMISSION FILE
+4 ;
+5 NEW ACRFMS,X,X3,X4,X5,X6
+6 IF '$DATA(^TMP("ACR",$JOB,"EXP"))
QUIT
+7 SET X7=$PIECE(AFSEXFN,"/",$LENGTH(AFSEXFN,"/"))
+8 SET ACRFMS=0
+9 FOR
SET ACRFMS=$ORDER(^TMP("ACR",$JOB,"EXP",ACRFMS))
IF 'ACRFMS
QUIT
Begin DoDot:1
+10 SET X=^TMP("ACR",$JOB,"EXP",ACRFMS)
+11 SET X3=$PIECE(X,U)
+12 SET X4=$PIECE(X,U,2)
+13 SET X5=$PIECE(X,U,3)
+14 SET X6=$PIECE(X,U,4)
+15 DO LINK^ACRFDHRE(ACRFMS,DT,X3,X4,X5,X6,X7)
End DoDot:1
+16 KILL ^TMP("ACR",$JOB,"EXP")
+17 QUIT
