- 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 Feb 18, 2025@23:39:31 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