IBCFP1 ;ALB/ARH - PRINT AUTHORIZED BILLS IN ORDER ;6-DEC-94
;;2.0;INTEGRATED BILLING;**54,52,80,121,51,137,155,320,348,349,718**;21-MAR-94;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
QTASK ; 1st part sorts authorized bills into order requested by bill form type then queues off 1 job for each type to print bills
;
D GCLEAN S IBXP=$$FMADD^XLFDT(DT,1)_"^"_DT_"^BATCH PRINT BILLS "_$$HTE^XLFDT($H)_" by "_$S($D(^VA(200,+$G(DUZ),0)):$P(^(0),"^"),1:"Unknown User")
SORT ;sort authorized bills by form type and requested sort order (notice bill addendums only print for 1500's)
S (IBQ,IBIFN)=0 F S IBIFN=$O(^DGCR(399,"AST",3,IBIFN)) Q:'IBIFN!IBQ D I $$STOP S IBQ=1 Q
. Q:+$$TXMT^IBCEF4(IBIFN)=1 ;Exclude transmittable bills
. S IBFT=$$FT^IBCU3(IBIFN) Q:$P($G(^IBE(353,+IBFT,0)),U,2)="" I IBFT'?1N Q ;No device for form type
. S IBX=$G(^DGCR(399,IBIFN,0)),IBPAT=$P($G(^DPT(+$P(IBX,U,2),0)),U,1) Q:$P(IBX,U,13)'=3
. S IBZIP=$P($G(^DGCR(399,IBIFN,"M")),U,9),IBINS=$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"MP")),0)),U,1)
. S IBX=IBZIP_U_IBINS_U_IBPAT,IBS1=$P(IBX,U,$E(IBS,1))_" ",IBS2=$P(IBX,U,$E(IBS,2))_" ",IBS3=$P(IBX,U,$E(IBS,3))_" "
. S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)=""
. S XIBFT=IBFT ;save off curent value of IBFT
. ;
. ; set MRA queue to print
. S IBFT=$$FNT^IBCU3("MRA")
. ; Merge the data from ^XTMP("IBCFP" queue, into "IBMRA" queue
. I +IBFT,$P($G(^IBE(353,+IBFT,0)),U,2)'="" S ^XTMP("IBMRA"_IBFT,0)=IBXP M ^XTMP("IBMRA"_IBFT,$J)=^XTMP("IBCFP"_XIBFT,$J)
. ;
. ; Print Bill Addendums only for 1500's
. I $$FTN^IBCU3(XIBFT)'["CMS-1500" Q
. S IBFT=$$FNT^IBCU3("BILL ADDENDUM")
. I +IBFT,$P($G(^IBE(353,+IBFT,0)),U,2)'="" S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)=""
. Q
K IBIFN,IBFT,XIBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3,IBS,IBXP
;
QUEUE ; starts a queued job for each form type that an authorized bill was found for
; no form types without defined device
I IBQ D GCLEAN ;queued job stopped
I 'IBQ D
. ; queue a job for each form type
. S IBIX="IBCFP" F S IBIX=$O(^XTMP(IBIX)) Q:(IBIX'?1"IBCFP"1N) I $D(^XTMP(IBIX,$J)) S IBFT=$E(IBIX,6) D
. . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,IBJ=$J
. . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTSAVE("IBJ")=""
. . S ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT),ZTRTN="QBILL^IBCFP1" D ^%ZTLOAD
. ; Also queue a job to print MRA's, if any, for each bill
. S IBIX="IBMRA" F S IBIX=$O(^XTMP(IBIX)) Q:(IBIX'?1"IBMRA"1N) I $D(^XTMP(IBIX,$J)) S IBFT=$E(IBIX,6) D
. . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,IBJ=$J
. . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTSAVE("IBJ")=""
. . S ZTDESC="BATCH PRINTING MRA'S",ZTRTN="QMRA^IBCEMU2" D ^%ZTLOAD
K IBIX,IBY,IBFTP,IBJ ; end of first queued part
Q
;
GCLEAN ; Clean up XTMP global for $J of IBCFP and IBMRA entries
N I
S I="IBCFP" F S I=$O(^XTMP(I)) Q:I'?1"IBCFP"1N.N K ^XTMP(I)
S I="IBMRA" F S I=$O(^XTMP(I)) Q:I'?1"IBMRA"1N.N K ^XTMP(I)
Q
;
QBILL ; 2nd queued part will print all authorized bills for a specific form type
N IBF,IBFORM,IBPNT
S IBF=$P($G(^IBE(353,+IBFT,2)),U,8),IBPNT=1
I $D(IBMCSPNT) S IBPNT=IBMCSPNT ; IB*320 - MCS resubmit by print
I IBF'="" S IBFORM=IBF D FORMOUT^IBCEFG7 Q ;call formatter
;
QB1 ; Entrypoint for output logic of formatter
; pass in "^XTMP(IBFTP,IBJ)" sorted array of bills to print
; IBFTP = "IBCFP"_(form type) subscript indicating which part of array to print
; IBPNT = reprint status of bill (1-original, 0-copy, etc)
; IBFT = IFN of bill form type to be printed
; IBJ = $J of starting job (for when multiple print jobs might be queued)
; if a single bill printed and queued, IBJ will be null
S:$G(IBJ)="" IBJ=$J
S:'$D(IBPNT) IBPNT=1
N IBCT,IBBN,IBS1,IBS2,IBS3,IBQ,IBIFN
S (IBCT,IBQ,IBS1)=0
S ZTREQ="@"
F S IBS1=$O(^XTMP(IBFTP,IBJ,IBS1)) Q:IBS1=""!IBQ D
. S IBS2=0 F S IBS2=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2)) Q:IBS2=""!IBQ D
.. S IBS3=0 F S IBS3=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3)) Q:IBS3=""!IBQ D
... S IBBN=0 F S IBBN=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBBN)) Q:IBBN="" D I $$STOP S IBQ=1 Q
.... D ROUT(IBFT,IBPNT,IBBN,.IBCT)
K ^XTMP(IBFTP,IBJ) ; end of last queued part
Q
;
;WCJ;IB718v22;adding a parameter to execute FSC workarounds in the post processing routine/s)
;ROUT(IBFT,IBPNT,IBIFN,IBCT,IBF,IBXPOSTWA) ; sub procedure to protect variables with new
ROUT(IBFT,IBPNT,IBIFN,IBCT,IBF,IBXPOSTWA) ; sub procedure to protect variables with new
; IBXPOSTWA = 1 if executing FSC post processing workarounds ;WCJ;IB718v22;
N IBBN,IBS1,IBS2,IBS3,IBQ,IBFTP,IBJ,IBXPARM,Z
D BILLPARM^IBCEFG0(IBIFN,.IBXPARM)
S IBF=$S($G(IBF)'="":IBF,1:$P($G(^IBE(353,+IBFT,2)),U,8))
S IBCT=$G(IBCT)+1
;
; IBF exists - use the Output Formatter for printing
; 2.08 field in file 353 - PRINT FORM NAME
;WCJ;IB718v22;adding a parameter to execute FSC workarounds in the post processing routine/s)
;I IBF'="" S Z=$$EXTRACT^IBCEFG(IBF,IBIFN,.IBCT,.IBXPARM) G REX
I IBF'="" S Z=$$EXTRACT^IBCEFG(IBF,IBIFN,.IBCT,.IBXPARM,$G(IBXPOSTWA)) G REX
;
; IBF does not exist - Obsolete VistA extract/print routines
I IBFT=1 S DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2) D ENP^IBCF1 W @IOF G REX
I $$FTN^IBCU3(+IBFT)="HCFA 1500" D EN^IBCF2 W @IOF G REX
I $$FTN^IBCU3(+IBFT)="UB-92" D EN^IBCF3 W @IOF G REX
;
; print bill addendums
I $$FTN^IBCU3(+IBFT)="BILL ADDENDUM" I +$$BILLAD^IBCF4(IBIFN) D EN^IBCF4 W @IOF G REX
;
REX Q
;
DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
STOP() ;determine if user has requested the queued report to stop
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
Q +$G(ZTSTOP)
;
FORMPRE ; Set up environment for bill message
K ^TMP("IBXMSG",$J),^TMP("IBXERR",$J),IBXERR,^TMP("IBXDATA",$J)
Q
;
FORMPOST ; Clean up
I $O(^TMP("IBXERR",$J,"")) D ;Error messages to mail group
.N XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
.K ^TMP("IBXMSG",$J)
.S ^TMP("IBXMSG",$J,1)="The following bill(s) were not printed due to errors indicated.",^(2)="Once the errors are corrected, the bill(s) can be printed again.",^(3)=" "
.;
.S IBERR=0,IBCT=3
.F S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR S IBCT=IBCT+1,^TMP("IBXMSG",$J,IBCT)="Bill #: "_$P($G(^DGCR(399,IBERR,0)),U),IBCT=IBCT+1,^TMP("IBXMSG",$J,IBCT)=$J("",5)_^TMP("IBXERR",$J,IBERR)
.S XMBODY="^TMP(""IBXMSG"","_$J_")" D ERRMSG(XMBODY)
.K ^TMP("IBXMSG",$J),^TMP($J,"IBICT")
;
K ^TMP("IBXERR",$J),IBXERR
D CLEAN^DILF
Q
;
ENTPRE ; Run before processing a bill entry
K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J)
Q
;
ENTPOST ; Run after processing a bill entry
N IBIFN
I $G(IBXERR)'="" S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J)
S IBIFN=IBXIEN D END^IBCF2
K IBXSAVE,^UTILITY("VAPA",$J),^TMP($J),^TMP("IBXSAVE",$J)
D CLEAN^DILF
Q
;
ERRMSG(XMBODY) ; Send bulletin for error message
N XMTO,XMSUBJ
S XMTO($G(DUZ))="",XMSUBJ="PRINT BILL ERRORS"
;
D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO)
D ALERT("One or more bills were not printed. Check your mail for details",$G(DUZ))
Q
;
ALERT(XQAMSG,IBGRP) ; Send alert message
N XQA
S XQA(IBGRP)=""
D SETUP^XQALERT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCFP1 7387 printed Oct 16, 2024@18:13:47 Page 2
IBCFP1 ;ALB/ARH - PRINT AUTHORIZED BILLS IN ORDER ;6-DEC-94
+1 ;;2.0;INTEGRATED BILLING;**54,52,80,121,51,137,155,320,348,349,718**;21-MAR-94;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
QTASK ; 1st part sorts authorized bills into order requested by bill form type then queues off 1 job for each type to print bills
+1 ;
+2 DO GCLEAN
SET IBXP=$$FMADD^XLFDT(DT,1)_"^"_DT_"^BATCH PRINT BILLS "_$$HTE^XLFDT($HOROLOG)_" by "_$SELECT($DATA(^VA(200,+$GET(DUZ),0)):$PIECE(^(0),"^"),1:"Unknown User")
SORT ;sort authorized bills by form type and requested sort order (notice bill addendums only print for 1500's)
+1 SET (IBQ,IBIFN)=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"AST",3,IBIFN))
if 'IBIFN!IBQ
QUIT
Begin DoDot:1
+2 ;Exclude transmittable bills
if +$$TXMT^IBCEF4(IBIFN)=1
QUIT
+3 ;No device for form type
SET IBFT=$$FT^IBCU3(IBIFN)
if $PIECE($GET(^IBE(353,+IBFT,0)),U,2)=""
QUIT
IF IBFT'?1N
QUIT
+4 SET IBX=$GET(^DGCR(399,IBIFN,0))
SET IBPAT=$PIECE($GET(^DPT(+$PIECE(IBX,U,2),0)),U,1)
if $PIECE(IBX,U,13)'=3
QUIT
+5 SET IBZIP=$PIECE($GET(^DGCR(399,IBIFN,"M")),U,9)
SET IBINS=$PIECE($GET(^DIC(36,+$GET(^DGCR(399,IBIFN,"MP")),0)),U,1)
+6 SET IBX=IBZIP_U_IBINS_U_IBPAT
SET IBS1=$PIECE(IBX,U,$EXTRACT(IBS,1))_" "
SET IBS2=$PIECE(IBX,U,$EXTRACT(IBS,2))_" "
SET IBS3=$PIECE(IBX,U,$EXTRACT(IBS,3))_" "
+7 SET ^XTMP("IBCFP"_IBFT,0)=IBXP
SET ^XTMP("IBCFP"_IBFT,$JOB,IBS1,IBS2,IBS3,IBIFN)=""
+8 ;save off curent value of IBFT
SET XIBFT=IBFT
+9 ;
+10 ; set MRA queue to print
+11 SET IBFT=$$FNT^IBCU3("MRA")
+12 ; Merge the data from ^XTMP("IBCFP" queue, into "IBMRA" queue
+13 IF +IBFT
IF $PIECE($GET(^IBE(353,+IBFT,0)),U,2)'=""
SET ^XTMP("IBMRA"_IBFT,0)=IBXP
MERGE ^XTMP("IBMRA"_IBFT,$JOB)=^XTMP("IBCFP"_XIBFT,$JOB)
+14 ;
+15 ; Print Bill Addendums only for 1500's
+16 IF $$FTN^IBCU3(XIBFT)'["CMS-1500"
QUIT
+17 SET IBFT=$$FNT^IBCU3("BILL ADDENDUM")
+18 IF +IBFT
IF $PIECE($GET(^IBE(353,+IBFT,0)),U,2)'=""
SET ^XTMP("IBCFP"_IBFT,0)=IBXP
SET ^XTMP("IBCFP"_IBFT,$JOB,IBS1,IBS2,IBS3,IBIFN)=""
+19 QUIT
End DoDot:1
IF $$STOP
SET IBQ=1
QUIT
+20 KILL IBIFN,IBFT,XIBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3,IBS,IBXP
+21 ;
QUEUE ; starts a queued job for each form type that an authorized bill was found for
+1 ; no form types without defined device
+2 ;queued job stopped
IF IBQ
DO GCLEAN
+3 IF 'IBQ
Begin DoDot:1
+4 ; queue a job for each form type
+5 SET IBIX="IBCFP"
FOR
SET IBIX=$ORDER(^XTMP(IBIX))
if (IBIX'?1"IBCFP"1N)
QUIT
IF $DATA(^XTMP(IBIX,$JOB))
SET IBFT=$EXTRACT(IBIX,6)
Begin DoDot:2
+6 SET ZTIO=$PIECE($GET(^IBE(353,+IBFT,0)),U,2)
SET IBFTP=IBIX
SET IBJ=$JOB
+7 SET ZTDTH=$HOROLOG
SET ZTSAVE("IBFTP")=""
SET ZTSAVE("IBFT")=""
SET ZTSAVE("IBJ")=""
+8 SET ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT)
SET ZTRTN="QBILL^IBCFP1"
DO ^%ZTLOAD
End DoDot:2
+9 ; Also queue a job to print MRA's, if any, for each bill
+10 SET IBIX="IBMRA"
FOR
SET IBIX=$ORDER(^XTMP(IBIX))
if (IBIX'?1"IBMRA"1N)
QUIT
IF $DATA(^XTMP(IBIX,$JOB))
SET IBFT=$EXTRACT(IBIX,6)
Begin DoDot:2
+11 SET ZTIO=$PIECE($GET(^IBE(353,+IBFT,0)),U,2)
SET IBFTP=IBIX
SET IBJ=$JOB
+12 SET ZTDTH=$HOROLOG
SET ZTSAVE("IBFTP")=""
SET ZTSAVE("IBFT")=""
SET ZTSAVE("IBJ")=""
+13 SET ZTDESC="BATCH PRINTING MRA'S"
SET ZTRTN="QMRA^IBCEMU2"
DO ^%ZTLOAD
End DoDot:2
End DoDot:1
+14 ; end of first queued part
KILL IBIX,IBY,IBFTP,IBJ
+15 QUIT
+16 ;
GCLEAN ; Clean up XTMP global for $J of IBCFP and IBMRA entries
+1 NEW I
+2 SET I="IBCFP"
FOR
SET I=$ORDER(^XTMP(I))
if I'?1"IBCFP"1N.N
QUIT
KILL ^XTMP(I)
+3 SET I="IBMRA"
FOR
SET I=$ORDER(^XTMP(I))
if I'?1"IBMRA"1N.N
QUIT
KILL ^XTMP(I)
+4 QUIT
+5 ;
QBILL ; 2nd queued part will print all authorized bills for a specific form type
+1 NEW IBF,IBFORM,IBPNT
+2 SET IBF=$PIECE($GET(^IBE(353,+IBFT,2)),U,8)
SET IBPNT=1
+3 ; IB*320 - MCS resubmit by print
IF $DATA(IBMCSPNT)
SET IBPNT=IBMCSPNT
+4 ;call formatter
IF IBF'=""
SET IBFORM=IBF
DO FORMOUT^IBCEFG7
QUIT
+5 ;
QB1 ; Entrypoint for output logic of formatter
+1 ; pass in "^XTMP(IBFTP,IBJ)" sorted array of bills to print
+2 ; IBFTP = "IBCFP"_(form type) subscript indicating which part of array to print
+3 ; IBPNT = reprint status of bill (1-original, 0-copy, etc)
+4 ; IBFT = IFN of bill form type to be printed
+5 ; IBJ = $J of starting job (for when multiple print jobs might be queued)
+6 ; if a single bill printed and queued, IBJ will be null
+7 if $GET(IBJ)=""
SET IBJ=$JOB
+8 if '$DATA(IBPNT)
SET IBPNT=1
+9 NEW IBCT,IBBN,IBS1,IBS2,IBS3,IBQ,IBIFN
+10 SET (IBCT,IBQ,IBS1)=0
+11 SET ZTREQ="@"
+12 FOR
SET IBS1=$ORDER(^XTMP(IBFTP,IBJ,IBS1))
if IBS1=""!IBQ
QUIT
Begin DoDot:1
+13 SET IBS2=0
FOR
SET IBS2=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2))
if IBS2=""!IBQ
QUIT
Begin DoDot:2
+14 SET IBS3=0
FOR
SET IBS3=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3))
if IBS3=""!IBQ
QUIT
Begin DoDot:3
+15 SET IBBN=0
FOR
SET IBBN=$ORDER(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBBN))
if IBBN=""
QUIT
Begin DoDot:4
+16 DO ROUT(IBFT,IBPNT,IBBN,.IBCT)
End DoDot:4
IF $$STOP
SET IBQ=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 ; end of last queued part
KILL ^XTMP(IBFTP,IBJ)
+18 QUIT
+19 ;
+20 ;WCJ;IB718v22;adding a parameter to execute FSC workarounds in the post processing routine/s)
+21 ;ROUT(IBFT,IBPNT,IBIFN,IBCT,IBF,IBXPOSTWA) ; sub procedure to protect variables with new
ROUT(IBFT,IBPNT,IBIFN,IBCT,IBF,IBXPOSTWA) ; sub procedure to protect variables with new
+1 ; IBXPOSTWA = 1 if executing FSC post processing workarounds ;WCJ;IB718v22;
+2 NEW IBBN,IBS1,IBS2,IBS3,IBQ,IBFTP,IBJ,IBXPARM,Z
+3 DO BILLPARM^IBCEFG0(IBIFN,.IBXPARM)
+4 SET IBF=$SELECT($GET(IBF)'="":IBF,1:$PIECE($GET(^IBE(353,+IBFT,2)),U,8))
+5 SET IBCT=$GET(IBCT)+1
+6 ;
+7 ; IBF exists - use the Output Formatter for printing
+8 ; 2.08 field in file 353 - PRINT FORM NAME
+9 ;WCJ;IB718v22;adding a parameter to execute FSC workarounds in the post processing routine/s)
+10 ;I IBF'="" S Z=$$EXTRACT^IBCEFG(IBF,IBIFN,.IBCT,.IBXPARM) G REX
+11 IF IBF'=""
SET Z=$$EXTRACT^IBCEFG(IBF,IBIFN,.IBCT,.IBXPARM,$GET(IBXPOSTWA))
GOTO REX
+12 ;
+13 ; IBF does not exist - Obsolete VistA extract/print routines
+14 IF IBFT=1
SET DFN=$PIECE($GET(^DGCR(399,+IBIFN,0)),U,2)
DO ENP^IBCF1
WRITE @IOF
GOTO REX
+15 IF $$FTN^IBCU3(+IBFT)="HCFA 1500"
DO EN^IBCF2
WRITE @IOF
GOTO REX
+16 IF $$FTN^IBCU3(+IBFT)="UB-92"
DO EN^IBCF3
WRITE @IOF
GOTO REX
+17 ;
+18 ; print bill addendums
+19 IF $$FTN^IBCU3(+IBFT)="BILL ADDENDUM"
IF +$$BILLAD^IBCF4(IBIFN)
DO EN^IBCF4
WRITE @IOF
GOTO REX
+20 ;
REX QUIT
+1 ;
DATE(X) QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+1 ;
STOP() ;determine if user has requested the queued report to stop
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
IF +$GET(IBPGN)
WRITE !,"***TASK STOPPED BY USER***"
+2 QUIT +$GET(ZTSTOP)
+3 ;
FORMPRE ; Set up environment for bill message
+1 KILL ^TMP("IBXMSG",$JOB),^TMP("IBXERR",$JOB),IBXERR,^TMP("IBXDATA",$JOB)
+2 QUIT
+3 ;
FORMPOST ; Clean up
+1 ;Error messages to mail group
IF $ORDER(^TMP("IBXERR",$JOB,""))
Begin DoDot:1
+2 NEW XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
+3 KILL ^TMP("IBXMSG",$JOB)
+4 SET ^TMP("IBXMSG",$JOB,1)="The following bill(s) were not printed due to errors indicated."
SET ^(2)="Once the errors are corrected, the bill(s) can be printed again."
SET ^(3)=" "
+5 ;
+6 SET IBERR=0
SET IBCT=3
+7 FOR
SET IBERR=$ORDER(^TMP("IBXERR",$JOB,IBERR))
if 'IBERR
QUIT
SET IBCT=IBCT+1
SET ^TMP("IBXMSG",$JOB,IBCT)="Bill #: "_$PIECE($GET(^DGCR(399,IBERR,0)),U)
SET IBCT=IBCT+1
SET ^TMP("IBXMSG",$JOB,IBCT)=$JUSTIFY("",5)_^TMP("IBXERR",$JOB,IBERR)
+8 SET XMBODY="^TMP(""IBXMSG"","_$JOB_")"
DO ERRMSG(XMBODY)
+9 KILL ^TMP("IBXMSG",$JOB),^TMP($JOB,"IBICT")
End DoDot:1
+10 ;
+11 KILL ^TMP("IBXERR",$JOB),IBXERR
+12 DO CLEAN^DILF
+13 QUIT
+14 ;
ENTPRE ; Run before processing a bill entry
+1 KILL IBXSAVE,IBXERR,^UTILITY("VAPA",$JOB),^TMP("IBXSAVE",$JOB),^TMP($JOB),^TMP("DIERR",$JOB)
+2 QUIT
+3 ;
ENTPOST ; Run after processing a bill entry
+1 NEW IBIFN
+2 IF $GET(IBXERR)'=""
SET ^TMP("IBXERR",$JOB,IBXIEN)=IBXERR
KILL ^TMP("IBXDATA",$JOB)
+3 SET IBIFN=IBXIEN
DO END^IBCF2
+4 KILL IBXSAVE,^UTILITY("VAPA",$JOB),^TMP($JOB),^TMP("IBXSAVE",$JOB)
+5 DO CLEAN^DILF
+6 QUIT
+7 ;
ERRMSG(XMBODY) ; Send bulletin for error message
+1 NEW XMTO,XMSUBJ
+2 SET XMTO($GET(DUZ))=""
SET XMSUBJ="PRINT BILL ERRORS"
+3 ;
+4 DO SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO)
+5 DO ALERT("One or more bills were not printed. Check your mail for details",$GET(DUZ))
+6 QUIT
+7 ;
ALERT(XQAMSG,IBGRP) ; Send alert message
+1 NEW XQA
+2 SET XQA(IBGRP)=""
+3 DO SETUP^XQALERT
+4 QUIT
