ACHSEOB8 ; IHS/ITSC/TPF/PMF - AREA WRITE EOBR FILES FOR FACILITIES (1/2) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,21,22,25**;JUN 11, 2001;Build 43
;
I '$O(^ACHSEOBR(0)) W *7,!!,"NO DATA EXISTS TO EXPORT TO FACILITIES.",!! S ACHSIO=IO D RTRN^ACHS G END
I $D(^ACHSEOBR("RUN")) U IO(0) W !!?5,*7,"FACILITY FILES HAVE ALREADY BEEN EXPORTED -- JOB CANCELLED" D RTRN^ACHS G END
S ACHSFLG=0,ACHSMSM=^%ZOSF("OS")["MSM"
I '$D(^ACHSAOP(DUZ(2),16,0)) S ^ACHSAOP(DUZ(2),16,0)=$$ZEROTH^ACHS(9002079.016,1)
W !,"Checking EOBR destinations...",!
S ACHS="0"
K DUOUT
D WAIT^DICD,DCHK
I '$D(DUOUT) G A
W !!,$$C^XBFUNC("You can use the 'Area Office Parameters' option to add a destination to"),!,$$C^XBFUNC("FACILITIES RECEIVING EOBR DATA.")
S Y=$$DIR^XBDIR("Y","Want to Continue with Incomplete EOBR Destination Information","N","","","",1)
I Y=1 G A
I $D(DUOUT)!(Y'=1) D END G K
A ;
D HOME^%ZIS
S ACHSEOBD=$P(^ACHSAOP(DUZ(2),2),U,11)
S ACHSPFAC="",ACHSMDIA="F"
F S ACHSPFAC=$O(^ACHSAOP(DUZ(2),16,"B",ACHSPFAC)) Q:ACHSPFAC=""!(ACHSFLG) D SEQ,CDATA,START:ACHSFAC
K ;
K ACHSFAC,ACHSFLG,ACHSMDIA,ACHSMSG,ACHSMSM,ACHSPFAC,ACHSEOBX,ACHSFACN,ACHSMCNT,ACHSR,ACHSRR,ACHSZRCT
S ACHSIO=IO
D RTRN^ACHS
Q
;
SEQ ; Load Seq Numbers for facility & file suffix name.
;ACHS*3.1*22 SET FILE EXTENTION WITH ICD IF PROCESSING THE ICD9 FILE
;S ACHSAOSQ=$P(^ACHSAOP(DUZ(2),2),U,9),ACHSEBSQ=+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
S ACHSAOSQ=$S(ACHSAOSQ["ICD":"ICD",1:$P(^ACHSAOP(DUZ(2),2),U,9)),ACHSEBSQ=+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
Q
;
CDATA ; Check if there is data to send to the facility.
S ACHSFACN=""
S:$D(^AUTTLOC(ACHSPFAC)) ACHSFACN=$P(^AUTTLOC(ACHSPFAC,0),U,10)
S ACHSFAC=""
F S ACHSFAC=$O(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC)) Q:ACHSFAC="" Q:$D(^ACHSEOBR(ACHSFAC))
Q
;
START ;
U IO(0)
W !!,"Copying EOBR data for ",$P(^DIC(4,ACHSPFAC,0),U,1),!," to host file.",!
D HFS
Q
;
HFS ;
U IO(0)
W !!,"Host File Being Created",*7
F Q:$L(ACHSAOSQ)=3 S ACHSAOSQ="0"_ACHSAOSQ
S ACHSZFN="EB"_ACHSFACN_"."_ACHSAOSQ
;ACHS*3.1*21 3 NEW LINES COM OUT 4TH
S ACHSEPTH=$$AOP^ACHS(3,3)
I ACHSEPTH="" S ACHSEPTH=$$EX^ACHS
I $$OPEN^%ZISH(ACHSEPTH,ACHSZFN,"W") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G CLOSE
;I $$OPEN^%ZISH($$EX^ACHS,ACHSZFN,"W") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G CLOSE
U IO(0)
;ACHS*3.1*18 PATCH FOR FT DEF;ACHS*3.1*21 CHANGED $$EX^ACHS TO ACHSEPTH IN ELSE LINE
I $$ASF^ACHS(DUZ(2))=808301 W !,"Please Standby - Copying Data to Host File ",$$IM^ACHS,ACHSZFN,!
E W !,"Please Standby - Copying Data to Host File ",ACHSEPTH,ACHSZFN,!
D SAVE
S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)=ACHSEBSQ,$P(^(0),U,2)=DT
I ACHSAOSQ="ICD" S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,6)="Y" ;ACHS*3.1*22
;ACHS*3.1*19 2 NEW LINES FOR S UTE
I $$ASF^ACHS(DUZ(2))=252611,$$MV^%ZISH($$EX^ACHS,ACHSZFN,$$IM^ACHS,ACHSZFN) W !,"Moved files to import directory"
G:$$ASF^ACHS(DUZ(2))=252611 CLOSE
;G:$$ASF^ACHS(DUZ(2))="000000" SEND ;ACHS*3.1*21 ADDED FOR TUC NO LONGER NEEDED FOR LEGACY SYSTEMS
G:$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,5)="N" CLOSE ;ACHS*3.1*21
I $$OS^ACHS=1,'$L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) D G CLOSE:'$L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1))
. N DA,DIE,DR
. W *7,!!?10,"System-ID Missing from Location File for ",$P(^DIC(4,ACHSPFAC,0),U)
. W !?10,"So the file can be sent, please enter the system ID, now:"
. S DIE="^AUTTLOC(",DR=.29,DA=ACHSPFAC
. D ^DIE
. I $L($P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) W !?10,"Thank you."
. E W !?10,"Well....you can STILL send it, manually."
. D RTRN^ACHS
.Q
SEND ;ACHS*3.1*21 ADDED FOR TUC LEGACY SYS
S ACHSSYS="",X=$P(^AUTTLOC(ACHSPFAC,0),U,10)
S ACHSSYS=$S(X="000111":"161.223.1.95",X="000111":"161.223.2.85",X="000200":"161.223.4.200",1:$P($G(^AUTTLOC(ACHSPFAC,1)),U,1))
;ACHS*3.1.*21 CHANGED NEXT LINE TO ACHSEPTH AND CHANGED $P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) TO ACHSSYS
;ACHS*3.1*25 ADDED TO CHECK FOR ZISH PARAMETER
S ACHSZPAR=""
I $D(^%ZIB(9888888.93,"B",ACHSSYS)) D
.S X="",X=$O(^%ZIB(9888888.93,"B",ACHSSYS,X))
.S ACHSZPAR=$P(^%ZIB(9888888.93,X,0),U,6)_" "_$P(^%ZIB(9888888.93,X,0),U,3)_":"_$P(^%ZIB(9888888.93,X,0),U,4)
;S Y=$$SEND^%ZISH("/dir/","fl","mach","ftpsend param")
;I $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS),$$OS^ACHS=1 W *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",! G CLOSE
I $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS,ACHSZPAR),$$OS^ACHS=1 W *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",! G CLOSE
; NOTE: Above has to check OS because the Unix SEND returns 0 if
; successful, and the DOS SEND returns a positive integer if
; successful. GTH 06-24-96.
W !!,"Export file ",ACHSZFN," queued up to be sent to ",$P($G(^AUTTLOC(ACHSPFAC,1)),U),"...",!
CLOSE ;EP.
D ^%ZISC
I ACHSFLG S ACHSIO=IO I ACHSMDIA'="F" D RTRN^ACHS
S ^ACHSEOBR("RUN")=$$HTFM^XLFDT($H)_"^"_DUZ
END ;
K %MT,ACHS,ACHSFAC,R,ACHSRCTR,X1,X2,ACHSZPAR
Q
;
SAVE ;EP.
D WAIT^DICD
U IO(0)
W !
S ACHSFAC="",ACHSZRCT=0
U IO
W "$$"_ACHSEOBD_" "_ACHSEBSQ,! ;W:IOPAR'["V" !
I +$P(^ACHSAOP(DUZ(2),2),U,10)'<+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3) D EXPMSG I 1
E W "$$",! ;W:IOPAR'["V" !
U IO
F S ACHSFAC=$O(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC)) Q:ACHSFAC="" D
. F ACHSCTR=0:0 S ACHSCTR=$O(^ACHSEOBR(ACHSFAC,ACHSCTR)) Q:'ACHSCTR W ^(ACHSCTR),! D
.. I $E(^ACHSEOBR(ACHSFAC,ACHSCTR),19)="A" D ADD^ACHSAOPO($TR($E(^(ACHSCTR),52,63),"-"),"EOBR",^(ACHSCTR))
.. S ACHSZRCT=ACHSZRCT+1
.. I ACHSZRCT#50=0 U IO(0) W $J(ACHSZRCT,8) U IO
..Q
.Q
W "**"_DT ;W:IOPAR'["V" !
U IO(0)
Q
;
EXPMSG ;
S (ACHSR,ACHSRR,ACHSMCNT)=0
EXP1 ;
S ACHSR=$O(^ACHSEOBM(ACHSR))
G EXPEND:+ACHSR=0
S ACHSRR=0
EXP2 ;
S ACHSRR=$O(^ACHSEOBM(ACHSR,1,ACHSRR))
G EXP1:+ACHSRR=0
S ACHSMCNT=ACHSMCNT+1,ACHSEOBX=$E("000",1,3-$L(ACHSMCNT))_ACHSMCNT_$P(^ACHSEOBM(ACHSR,0),U,1)_^ACHSEOBM(ACHSR,1,ACHSRR,0)
U IO
W ACHSEOBX
W:IOPAR'["V" !
G EXP2
;
EXPEND ;
U IO
W "$$"
W:IOPAR'["V" !
U IO(0)
W !?10,"EOBR Messages Copied to Output Media",!
S $P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3)=DT
Q
;
DCHK ;Check Destinations of EOBRs.
S ACHS=$O(^ACHSEOBR(ACHS))
Q:+ACHS=0!(ACHS="ER")
I $D(^ACHSAOP(DUZ(2),16,"D",ACHS)) G DCHK
W *7,!,"Destination not on file for ",$P(^DIC(4,ACHS,0),U,1)
S DUOUT=""
G DCHK
;
ACHSEOB8 ; IHS/ITSC/TPF/PMF - AREA WRITE EOBR FILES FOR FACILITIES (1/2) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,19,21,22,25**;JUN 11, 2001;Build 43
+2 ;
+3 IF '$ORDER(^ACHSEOBR(0))
WRITE *7,!!,"NO DATA EXISTS TO EXPORT TO FACILITIES.",!!
SET ACHSIO=IO
DO RTRN^ACHS
GOTO END
+4 IF $DATA(^ACHSEOBR("RUN"))
USE IO(0)
WRITE !!?5,*7,"FACILITY FILES HAVE ALREADY BEEN EXPORTED -- JOB CANCELLED"
DO RTRN^ACHS
GOTO END
+5 SET ACHSFLG=0
SET ACHSMSM=^%ZOSF("OS")["MSM"
+6 IF '$DATA(^ACHSAOP(DUZ(2),16,0))
SET ^ACHSAOP(DUZ(2),16,0)=$$ZEROTH^ACHS(9002079.016,1)
+7 WRITE !,"Checking EOBR destinations...",!
+8 SET ACHS="0"
+9 KILL DUOUT
+10 DO WAIT^DICD
DO DCHK
+11 IF '$DATA(DUOUT)
GOTO A
+12 WRITE !!,$$C^XBFUNC("You can use the 'Area Office Parameters' option to add a destination to"),!,$$C^XBFUNC("FACILITIES RECEIVING EOBR DATA.")
+13 SET Y=$$DIR^XBDIR("Y","Want to Continue with Incomplete EOBR Destination Information","N","","","",1)
+14 IF Y=1
GOTO A
+15 IF $DATA(DUOUT)!(Y'=1)
DO END
GOTO K
A ;
+1 DO HOME^%ZIS
+2 SET ACHSEOBD=$PIECE(^ACHSAOP(DUZ(2),2),U,11)
+3 SET ACHSPFAC=""
SET ACHSMDIA="F"
+4 FOR
SET ACHSPFAC=$ORDER(^ACHSAOP(DUZ(2),16,"B",ACHSPFAC))
IF ACHSPFAC=""!(ACHSFLG)
QUIT
DO SEQ
DO CDATA
IF ACHSFAC
DO START
K ;
+1 KILL ACHSFAC,ACHSFLG,ACHSMDIA,ACHSMSG,ACHSMSM,ACHSPFAC,ACHSEOBX,ACHSFACN,ACHSMCNT,ACHSR,ACHSRR,ACHSZRCT
+2 SET ACHSIO=IO
+3 DO RTRN^ACHS
+4 QUIT
+5 ;
SEQ ; Load Seq Numbers for facility & file suffix name.
+1 ;ACHS*3.1*22 SET FILE EXTENTION WITH ICD IF PROCESSING THE ICD9 FILE
+2 ;S ACHSAOSQ=$P(^ACHSAOP(DUZ(2),2),U,9),ACHSEBSQ=+$P(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
+3 SET ACHSAOSQ=$SELECT(ACHSAOSQ["ICD":"ICD",1:$PIECE(^ACHSAOP(DUZ(2),2),U,9))
SET ACHSEBSQ=+$PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)+1
+4 QUIT
+5 ;
CDATA ; Check if there is data to send to the facility.
+1 SET ACHSFACN=""
+2 IF $DATA(^AUTTLOC(ACHSPFAC))
SET ACHSFACN=$PIECE(^AUTTLOC(ACHSPFAC,0),U,10)
+3 SET ACHSFAC=""
+4 FOR
SET ACHSFAC=$ORDER(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC))
IF ACHSFAC=""
QUIT
IF $DATA(^ACHSEOBR(ACHSFAC))
QUIT
+5 QUIT
+6 ;
START ;
+1 USE IO(0)
+2 WRITE !!,"Copying EOBR data for ",$PIECE(^DIC(4,ACHSPFAC,0),U,1),!," to host file.",!
+3 DO HFS
+4 QUIT
+5 ;
HFS ;
+1 USE IO(0)
+2 WRITE !!,"Host File Being Created",*7
+3 FOR
IF $LENGTH(ACHSAOSQ)=3
QUIT
SET ACHSAOSQ="0"_ACHSAOSQ
+4 SET ACHSZFN="EB"_ACHSFACN_"."_ACHSAOSQ
+5 ;ACHS*3.1*21 3 NEW LINES COM OUT 4TH
+6 SET ACHSEPTH=$$AOP^ACHS(3,3)
+7 IF ACHSEPTH=""
SET ACHSEPTH=$$EX^ACHS
+8 IF $$OPEN^%ZISH(ACHSEPTH,ACHSZFN,"W")
SET ACHSEMSG="M10"
DO ERROR^ACHSTCK1
GOTO CLOSE
+9 ;I $$OPEN^%ZISH($$EX^ACHS,ACHSZFN,"W") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G CLOSE
+10 USE IO(0)
+11 ;ACHS*3.1*18 PATCH FOR FT DEF;ACHS*3.1*21 CHANGED $$EX^ACHS TO ACHSEPTH IN ELSE LINE
+12 IF $$ASF^ACHS(DUZ(2))=808301
WRITE !,"Please Standby - Copying Data to Host File ",$$IM^ACHS,ACHSZFN,!
+13 IF '$TEST
WRITE !,"Please Standby - Copying Data to Host File ",ACHSEPTH,ACHSZFN,!
+14 DO SAVE
+15 SET $PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,4)=ACHSEBSQ
SET $PIECE(^(0),U,2)=DT
+16 ;ACHS*3.1*22
IF ACHSAOSQ="ICD"
SET $PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,6)="Y"
+17 ;ACHS*3.1*19 2 NEW LINES FOR S UTE
+18 IF $$ASF^ACHS(DUZ(2))=252611
IF $$MV^%ZISH($$EX^ACHS,ACHSZFN,$$IM^ACHS,ACHSZFN)
WRITE !,"Moved files to import directory"
+19 IF $$ASF^ACHS(DUZ(2))=252611
GOTO CLOSE
+20 ;G:$$ASF^ACHS(DUZ(2))="000000" SEND ;ACHS*3.1*21 ADDED FOR TUC NO LONGER NEEDED FOR LEGACY SYSTEMS
+21 ;ACHS*3.1*21
IF $PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,5)="N"
GOTO CLOSE
+22 IF $$OS^ACHS=1
IF '$LENGTH($PIECE($GET(^AUTTLOC(ACHSPFAC,1)),U,1))
Begin DoDot:1
+23 NEW DA,DIE,DR
+24 WRITE *7,!!?10,"System-ID Missing from Location File for ",$PIECE(^DIC(4,ACHSPFAC,0),U)
+25 WRITE !?10,"So the file can be sent, please enter the system ID, now:"
+26 SET DIE="^AUTTLOC("
SET DR=.29
SET DA=ACHSPFAC
+27 DO ^DIE
+28 IF $LENGTH($PIECE($GET(^AUTTLOC(ACHSPFAC,1)),U,1))
WRITE !?10,"Thank you."
+29 IF '$TEST
WRITE !?10,"Well....you can STILL send it, manually."
+30 DO RTRN^ACHS
+31 QUIT
End DoDot:1
IF '$LENGTH($PIECE($GET(^AUTTLOC(ACHSPFAC,1)),U,1))
GOTO CLOSE
SEND ;ACHS*3.1*21 ADDED FOR TUC LEGACY SYS
+1 SET ACHSSYS=""
SET X=$PIECE(^AUTTLOC(ACHSPFAC,0),U,10)
+2 SET ACHSSYS=$SELECT(X="000111":"161.223.1.95",X="000111":"161.223.2.85",X="000200":"161.223.4.200",1:$PIECE($GET(^AUTTLOC(ACHSPFAC,1)),U,1))
+3 ;ACHS*3.1.*21 CHANGED NEXT LINE TO ACHSEPTH AND CHANGED $P($G(^AUTTLOC(ACHSPFAC,1)),U,1)) TO ACHSSYS
+4 ;ACHS*3.1*25 ADDED TO CHECK FOR ZISH PARAMETER
+5 SET ACHSZPAR=""
+6 IF $DATA(^%ZIB(9888888.93,"B",ACHSSYS))
Begin DoDot:1
+7 SET X=""
SET X=$ORDER(^%ZIB(9888888.93,"B",ACHSSYS,X))
+8 SET ACHSZPAR=$PIECE(^%ZIB(9888888.93,X,0),U,6)_" "_$PIECE(^%ZIB(9888888.93,X,0),U,3)_":"_$PIECE(^%ZIB(9888888.93,X,0),U,4)
End DoDot:1
+9 ;S Y=$$SEND^%ZISH("/dir/","fl","mach","ftpsend param")
+10 ;I $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS),$$OS^ACHS=1 W *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",! G CLOSE
+11 IF $$SEND^%ZISH(ACHSEPTH,ACHSZFN,ACHSSYS,ACHSZPAR)
IF $$OS^ACHS=1
WRITE *7,!!?10,"$$SEND^%ZISH() of ",ACHSEPTH,ACHSZFN," to ",ACHSSYS," failed -- Notify Supervisor",!
GOTO CLOSE
+12 ; NOTE: Above has to check OS because the Unix SEND returns 0 if
+13 ; successful, and the DOS SEND returns a positive integer if
+14 ; successful. GTH 06-24-96.
+15 WRITE !!,"Export file ",ACHSZFN," queued up to be sent to ",$PIECE($GET(^AUTTLOC(ACHSPFAC,1)),U),"...",!
CLOSE ;EP.
+1 DO ^%ZISC
+2 IF ACHSFLG
SET ACHSIO=IO
IF ACHSMDIA'="F"
DO RTRN^ACHS
+3 SET ^ACHSEOBR("RUN")=$$HTFM^XLFDT($HOROLOG)_"^"_DUZ
END ;
+1 KILL %MT,ACHS,ACHSFAC,R,ACHSRCTR,X1,X2,ACHSZPAR
+2 QUIT
+3 ;
SAVE ;EP.
+1 DO WAIT^DICD
+2 USE IO(0)
+3 WRITE !
+4 SET ACHSFAC=""
SET ACHSZRCT=0
+5 USE IO
+6 ;W:IOPAR'["V" !
WRITE "$$"_ACHSEOBD_" "_ACHSEBSQ,!
+7 IF +$PIECE(^ACHSAOP(DUZ(2),2),U,10)'<+$PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3)
DO EXPMSG
IF 1
+8 ;W:IOPAR'["V" !
IF '$TEST
WRITE "$$",!
+9 USE IO
+10 FOR
SET ACHSFAC=$ORDER(^ACHSAOP(DUZ(2),16,"C",ACHSPFAC,ACHSFAC))
IF ACHSFAC=""
QUIT
Begin DoDot:1
+11 FOR ACHSCTR=0:0
SET ACHSCTR=$ORDER(^ACHSEOBR(ACHSFAC,ACHSCTR))
IF 'ACHSCTR
QUIT
WRITE ^(ACHSCTR),!
Begin DoDot:2
+12 IF $EXTRACT(^ACHSEOBR(ACHSFAC,ACHSCTR),19)="A"
DO ADD^ACHSAOPO($TRANSLATE($EXTRACT(^(ACHSCTR),52,63),"-"),"EOBR",^(ACHSCTR))
+13 SET ACHSZRCT=ACHSZRCT+1
+14 IF ACHSZRCT#50=0
USE IO(0)
WRITE $JUSTIFY(ACHSZRCT,8)
USE IO
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 ;W:IOPAR'["V" !
WRITE "**"_DT
+18 USE IO(0)
+19 QUIT
+20 ;
EXPMSG ;
+1 SET (ACHSR,ACHSRR,ACHSMCNT)=0
EXP1 ;
+1 SET ACHSR=$ORDER(^ACHSEOBM(ACHSR))
+2 IF +ACHSR=0
GOTO EXPEND
+3 SET ACHSRR=0
EXP2 ;
+1 SET ACHSRR=$ORDER(^ACHSEOBM(ACHSR,1,ACHSRR))
+2 IF +ACHSRR=0
GOTO EXP1
+3 SET ACHSMCNT=ACHSMCNT+1
SET ACHSEOBX=$EXTRACT("000",1,3-$LENGTH(ACHSMCNT))_ACHSMCNT_$PIECE(^ACHSEOBM(ACHSR,0),U,1)_^ACHSEOBM(ACHSR,1,ACHSRR,0)
+4 USE IO
+5 WRITE ACHSEOBX
+6 IF IOPAR'["V"
WRITE !
+7 GOTO EXP2
+8 ;
EXPEND ;
+1 USE IO
+2 WRITE "$$"
+3 IF IOPAR'["V"
WRITE !
+4 USE IO(0)
+5 WRITE !?10,"EOBR Messages Copied to Output Media",!
+6 SET $PIECE(^ACHSAOP(DUZ(2),16,ACHSPFAC,0),U,3)=DT
+7 QUIT
+8 ;
DCHK ;Check Destinations of EOBRs.
+1 SET ACHS=$ORDER(^ACHSEOBR(ACHS))
+2 IF +ACHS=0!(ACHS="ER")
QUIT
+3 IF $DATA(^ACHSAOP(DUZ(2),16,"D",ACHS))
GOTO DCHK
+4 WRITE *7,!,"Destination not on file for ",$PIECE(^DIC(4,ACHS,0),U,1)
+5 SET DUOUT=""
+6 GOTO DCHK
+7 ;
