source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCFP1.m@ 1154

Last change on this file since 1154 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.6 KB
RevLine 
[613]1IBCFP1 ;ALB/ARH - PRINT AUTHORIZED BILLS IN ORDER ;6-DEC-94
2 ;;2.0;INTEGRATED BILLING;**54,52,80,121,51,137,155,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;
6QTASK ; 1st part sorts authorized bills into order requested by bill form type then queues off 1 job for each type to print bills
7 ;
8 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")
9SORT ;sort authorized bills by form type and requested sort order (notice bill addendums only print for 1500's)
10 S (IBQ,IBIFN)=0 F S IBIFN=$O(^DGCR(399,"AST",3,IBIFN)) Q:'IBIFN!IBQ D I $$STOP S IBQ=1 Q
11 . Q:+$$TXMT^IBCEF4(IBIFN)=1 ;Exclude transmittable bills
12 . S IBFT=$$FT^IBCU3(IBIFN) Q:$P($G(^IBE(353,+IBFT,0)),U,2)="" I IBFT'?1N Q ;No device for form type
13 . S IBX=$G(^DGCR(399,IBIFN,0)),IBPAT=$P($G(^DPT(+$P(IBX,U,2),0)),U,1) Q:$P(IBX,U,13)'=3
14 . S IBZIP=$P($G(^DGCR(399,IBIFN,"M")),U,9),IBINS=$P($G(^DIC(36,+$G(^DGCR(399,IBIFN,"MP")),0)),U,1)
15 . 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))_" "
16 . S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)=""
17 . S XIBFT=IBFT ;save off curent value of IBFT
18 . ;
19 . ; set MRA queue to print
20 . S IBFT=$$FNT^IBCU3("MRA")
21 . ; Merge the data from ^XTMP("IBCFP" queue, into "IBMRA" queue
22 . 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)
23 . ;
24 . ; Print Bill Addendums only for 1500's
25 . I $$FTN^IBCU3(XIBFT)'["CMS-1500" Q
26 . S IBFT=$$FNT^IBCU3("BILL ADDENDUM")
27 . I +IBFT,$P($G(^IBE(353,+IBFT,0)),U,2)'="" S ^XTMP("IBCFP"_IBFT,0)=IBXP,^XTMP("IBCFP"_IBFT,$J,IBS1,IBS2,IBS3,IBIFN)=""
28 . Q
29 K IBIFN,IBFT,XIBFT,IBX,IBY,IBPAT,IBZIP,IBINS,IBS1,IBS2,IBS3,IBS,IBXP
30 ;
31QUEUE ; starts a queued job for each form type that an authorized bill was found for
32 ; no form types without defined device
33 I IBQ D GCLEAN ;queued job stopped
34 I 'IBQ D
35 . ; queue a job for each form type
36 . 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
37 . . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,IBJ=$J
38 . . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTSAVE("IBJ")=""
39 . . S ZTDESC="BATCH PRINTING "_$$FTN^IBCU3(+IBFT),ZTRTN="QBILL^IBCFP1" D ^%ZTLOAD
40 . ; Also queue a job to print MRA's, if any, for each bill
41 . 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
42 . . S ZTIO=$P($G(^IBE(353,+IBFT,0)),U,2),IBFTP=IBIX,IBJ=$J
43 . . S ZTDTH=$H,ZTSAVE("IBFTP")="",ZTSAVE("IBFT")="",ZTSAVE("IBJ")=""
44 . . S ZTDESC="BATCH PRINTING MRA'S",ZTRTN="QMRA^IBCEMU2" D ^%ZTLOAD
45 K IBIX,IBY,IBFTP,IBJ ; end of first queued part
46 Q
47 ;
48GCLEAN ; Clean up XTMP global for $J of IBCFP and IBMRA entries
49 N I
50 S I="IBCFP" F S I=$O(^XTMP(I)) Q:I'?1"IBCFP"1N.N K ^XTMP(I)
51 S I="IBMRA" F S I=$O(^XTMP(I)) Q:I'?1"IBMRA"1N.N K ^XTMP(I)
52 Q
53 ;
54QBILL ; 2nd queued part will print all authorized bills for a specific form type
55 N IBF,IBFORM,IBPNT
56 S IBF=$P($G(^IBE(353,+IBFT,2)),U,8),IBPNT=1
57 I $D(IBMCSPNT) S IBPNT=IBMCSPNT ; IB*320 - MCS resubmit by print
58 I IBF'="" S IBFORM=IBF D FORMOUT^IBCEFG7 Q ;call formatter
59 ;
60QB1 ; Entrypoint for output logic of formatter
61 ; pass in "^XTMP(IBFTP,IBJ)" sorted array of bills to print
62 ; IBFTP = "IBCFP"_(form type) subscript indicating which part of array to print
63 ; IBPNT = reprint status of bill (1-original, 0-copy, etc)
64 ; IBFT = IFN of bill form type to be printed
65 ; IBJ = $J of starting job (for when multiple print jobs might be queued)
66 ; if a single bill printed and queued, IBJ will be null
67 S:$G(IBJ)="" IBJ=$J
68 S:'$D(IBPNT) IBPNT=1
69 N IBCT,IBBN,IBS1,IBS2,IBS3,IBQ,IBIFN
70 S (IBCT,IBQ,IBS1)=0
71 S ZTREQ="@"
72 F S IBS1=$O(^XTMP(IBFTP,IBJ,IBS1)) Q:IBS1=""!IBQ D
73 . S IBS2=0 F S IBS2=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2)) Q:IBS2=""!IBQ D
74 .. S IBS3=0 F S IBS3=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3)) Q:IBS3=""!IBQ D
75 ... S IBBN=0 F S IBBN=$O(^XTMP(IBFTP,IBJ,IBS1,IBS2,IBS3,IBBN)) Q:IBBN="" D I $$STOP S IBQ=1 Q
76 .... D ROUT(IBFT,IBPNT,IBBN,.IBCT)
77 K ^XTMP(IBFTP,IBJ) ; end of last queued part
78 Q
79 ;
80ROUT(IBFT,IBPNT,IBIFN,IBCT,IBF) ; sub procedure to protect variables with new
81 N IBBN,IBS1,IBS2,IBS3,IBQ,IBFTP,IBJ,IBXPARM,Z
82 D BILLPARM^IBCEFG0(IBIFN,.IBXPARM)
83 S IBF=$S($G(IBF)'="":IBF,1:$P($G(^IBE(353,+IBFT,2)),U,8))
84 S IBCT=$G(IBCT)+1
85 ;
86 ; IBF exists - use the Output Formatter for printing
87 ; 2.08 field in file 353 - PRINT FORM NAME
88 I IBF'="" S Z=$$EXTRACT^IBCEFG(IBF,IBIFN,.IBCT,.IBXPARM) G REX
89 ;
90 ; IBF does not exist - Obsolete VistA extract/print routines
91 I IBFT=1 S DFN=$P($G(^DGCR(399,+IBIFN,0)),U,2) D ENP^IBCF1 W @IOF G REX
92 I $$FTN^IBCU3(+IBFT)="HCFA 1500" D EN^IBCF2 W @IOF G REX
93 I $$FTN^IBCU3(+IBFT)="UB-92" D EN^IBCF3 W @IOF G REX
94 ;
95 ; print bill addendums
96 I $$FTN^IBCU3(+IBFT)="BILL ADDENDUM" I +$$BILLAD^IBCF4(IBIFN) D EN^IBCF4 W @IOF G REX
97 ;
98REX Q
99 ;
100DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
101 ;
102STOP() ;determine if user has requested the queued report to stop
103 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
104 Q +$G(ZTSTOP)
105 ;
106FORMPRE ; Set up environment for bill message
107 K ^TMP("IBXMSG",$J),^TMP("IBXERR",$J),IBXERR,^TMP("IBXDATA",$J)
108 Q
109 ;
110FORMPOST ; Clean up
111 I $O(^TMP("IBXERR",$J,"")) D ;Error messages to mail group
112 .N XMTO,XMBODY,XMDUZ,XMSUBJ,IBCT,IBERR
113 .K ^TMP("IBXMSG",$J)
114 .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)=" "
115 .;
116 .S IBERR=0,IBCT=3
117 .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)
118 .S XMBODY="^TMP(""IBXMSG"","_$J_")" D ERRMSG(XMBODY)
119 .K ^TMP("IBXMSG",$J),^TMP($J,"IBICT")
120 ;
121 K ^TMP("IBXERR",$J),IBXERR
122 D CLEAN^DILF
123 Q
124 ;
125ENTPRE ; Run before processing a bill entry
126 K IBXSAVE,IBXERR,^UTILITY("VAPA",$J),^TMP("IBXSAVE",$J),^TMP($J),^TMP("DIERR",$J)
127 Q
128 ;
129ENTPOST ; Run after processing a bill entry
130 N IBIFN
131 I $G(IBXERR)'="" S ^TMP("IBXERR",$J,IBXIEN)=IBXERR K ^TMP("IBXDATA",$J)
132 S IBIFN=IBXIEN D END^IBCF2
133 K IBXSAVE,^UTILITY("VAPA",$J),^TMP($J),^TMP("IBXSAVE",$J)
134 D CLEAN^DILF
135 Q
136 ;
137ERRMSG(XMBODY) ; Send bulletin for error message
138 N XMTO,XMSUBJ
139 S XMTO($G(DUZ))="",XMSUBJ="PRINT BILL ERRORS"
140 ;
141 D SENDMSG^XMXAPI(,XMSUBJ,XMBODY,.XMTO)
142 D ALERT("One or more bills were not printed. Check your mail for details",$G(DUZ))
143 Q
144 ;
145ALERT(XQAMSG,IBGRP) ; Send alert message
146 N XQA
147 S XQA(IBGRP)=""
148 D SETUP^XQALERT
149 Q
Note: See TracBrowser for help on using the repository browser.