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

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1IBTUBAV ;ALB/AAS - UNBILLED AMOUNTS - AVERAGE BILL AMOUNT LOGIC ; 29-SEP-94
2 ;;2.0;INTEGRATED BILLING;**19,123**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% ; - Entry point for manual option.
6 I '$D(DT) D DT^DICRW
7 W !
8 ;
9DATE ; - Select date.
10 W ! D DT2^IBTUBOU("Average Bill Amounts") G:IBTIMON="^" END
11 ;
12DEV ; - Select device.
13 W !!,"This will automatically be tasked to run and needs no device."
14 W !!,"A mail Message will be sent when the process completes."
15 W !,"Use the option View Unbilled Amounts to see cumulative totals.",!!
16 S ZTRTN="DQ^IBTUBAV",ZTSAVE("IB*")="",ZTIO=""
17 S ZTDESC="IB - Generate Avg. Bill Amounts for a Month"
18 D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
19 ;
20AUTO ; - Entry point for scheduled option (update monthly number of bills
21 ; and prior 12 months fields).
22 ;
23 S IBCOMP=1 ; This will cause the mail msg to be sent to all the users
24 ; on the Unbilled Amounts mail group (see SEND^IBTUBUL).
25 ;
26DQ ; - Entry point for user options when queued.
27 K ^TMP($J,"IBTUBAV"),^TMP($J,"IBTUBAV1")
28 ;
29 ; - If no IBTIMON or in the future, sets it with current Month
30 I '$G(IBTIMON)!($G(IBTIMON)>(DT\100*100)) S IBTIMON=DT\100*100
31 ;
32 ; - Sets IBGMON with the 1st month 1 year prior to IBTIMON
33 S IBGMON=IBTIMON-10000
34 ;
35 ; AUG/1993 should be the first month in the Unbilled Amounts File
36 I IBGMON>2930800,'$D(^IBE(356.19,2930800,0)) D
37 . S IBGMON=2930800
38 ;
39 ; - Calculate/Store the Unbilled Amounts Data for the past 12 months
40 ; (Prior to IBTIMON, does NOT include IBTIMON)
41 F Q:IBGMON'<IBTIMON D
42 . ; - If there is no entry for the month, try to create an entry
43 . I '$D(^IBE(356.19,IBGMON,0)),'$$ADD(IBGMON) D Q
44 . . S IBGMON=$$FMADD^XLFDT(IBGMON,32)\100*100
45 . ;
46 . D MONTH(IBGMON) ; - Calculate MONTHLY totals and store if necessary
47 . D YEAR(IBGMON) ; - Calculate YEARLY totals and store if necessary
48 . ;
49 . S IBGMON=$$FMADD^XLFDT(IBGMON,32)\100*100
50 ;
51 ; - Calculate/Store MONTHLY & YEARLY totals for IBTIMON, if not the
52 ; current month
53 I $$ADD(IBTIMON),IBTIMON<(DT\100*100) D MONTH(IBTIMON,1)
54 D YEAR(IBTIMON,1)
55 ;
56 I $D(^TMP($J,"IBTUBAV"))!($D(^TMP($J,"IBTUBAV1"))) D SEND
57 ;
58END K ^TMP($J,"IBTUBAV"),^TMP($J,"IBTUBAV1")
59 I $D(ZTQUEUED) S ZTREQ="@" Q
60 K IBTIMON,IBCOMP,D,DIRUT,D0,%DT
61 Q
62 ;
63MONTH(IBYRMO,IBOVRW) ; - Calculate/update Inpatient Unbilled Amounts
64 ; Input: IBYRMO - YEAR/MONTH (YYYMM00) being calculated/updated
65 ; IBOVRW - Overwrite the data currently on file? (1-YES/0-NO)
66 ;
67 N BGDT,ENDT,IBAVG,IBAMT,IBDA,IBDFN,IBDT,IBNOD,X
68 ;
69 I '$G(IBYRMO) Q
70 K ^TMP($J,"IBTUBAV2")
71 ;
72 ; - If MONTHLY Average has already been calculated & NOT Overwrite->QUIT
73 I '$G(IBOVRW),$P($G(^IBE(356.19,IBYRMO,1)),"^",13)'="" Q
74 ;
75 S BGDT=IBYRMO+1,ENDT=IBYRMO+32
76 ;
77 ; - Initialize the IBAVG array (set at line tag INPT)
78 F X="I","P" S (IBAVG("$AMNT-"_X),IBAVG("BILLS-"_X),IBAVG("EPISD-"_X))=0
79 ;
80 ; - Loop through date entered x-ref starting a year prior to the period
81 S IBDT=BGDT-10000
82 F S IBDT=$O(^DGCR(399,"APD",IBDT)) Q:'IBDT!(IBDT>ENDT) D
83 . S IBDA=0 F S IBDA=$O(^DGCR(399,"APD",IBDT,IBDA)) Q:'IBDA D
84 . . S IBNOD=$G(^DGCR(399,+IBDA,0))
85 . . I $P(IBNOD,U,11)'="i" Q ; Not reimbursable insurance bill
86 . . S X=$P(IBNOD,U,13) Q:X<3!(X>6) ; Status not authorized or printed
87 . . S X=$P($G(^DGCR(399,+IBDA,"S")),U,10)
88 . . I X=""!(X<BGDT)!(X>ENDT) Q ; Date authorized must be in period
89 . . I $P(IBNOD,U,5)<3 D INPT
90 ;
91 ; - Updates file #356.19 with MONTHLY totals (Inpatient)
92 S IBAVG("$AMNT-I")=$J(IBAVG("$AMNT-I"),0,2)
93 S IBAVG("$AMNT-P")=$J(IBAVG("$AMNT-P"),0,2)
94 D LD^IBTUBOU(1,IBYRMO) S ^TMP($J,"IBTUBAV",IBYRMO)=""
95 ;
96 K ^TMP($J,"IBTUBAV2") Q
97 ;
98INPT ; - For inpatient bills (add count of bills/total dollars).
99 S IBDFN=$P(IBNOD,U,2,3),IBAMT=+$G(^DGCR(399,IBDA,"U1"))
100 I $P(IBNOD,U,27)=1!($P(IBNOD,U,19)=3) D G INP1
101 . S IBAVG("BILLS-I")=IBAVG("BILLS-I")+1
102 . S IBAVG("$AMNT-I")=IBAVG("$AMNT-I")+IBAMT
103 . S IBDFN=IBDFN_"^I"
104 ;
105 I $P(IBNOD,U,27)=2!($P(IBNOD,U,19)=2) D G INP1
106 . S IBAVG("BILLS-P")=IBAVG("BILLS-P")+1
107 . S IBAVG("$AMNT-P")=IBAVG("$AMNT-P")+IBAMT
108 . S IBDFN=IBDFN_"^P"
109 ;
110 G INPQ
111 ;
112INP1 ; - Add number of inpatient episodes.
113 I '$D(^TMP($J,"IBTUBAV2",IBDFN)) D
114 . S Y=$P(IBDFN,U,3),IBAVG("EPISD-"_Y)=IBAVG("EPISD-"_Y)+1
115 . S ^TMP($J,"IBTUBAV2",IBDFN)=""
116 ;
117INPQ Q
118 ;
119YEAR(IBYRMO,IBOVRW) ; - Calculate YEARLY totals, and store if necessary
120 ; - Input: IBYRMO - YEAR/MONTH (YYYMM00) being calculated/updated
121 ; IBOVRW - Overwrite the data currently on file? (1-YES/0-NO)
122 ;
123 N IBAVG,IBTMON,IBGMON,IBTNMON,DA,DIC,DIE,DR,SUBCNT,I,X
124 I IBYRMO>(DT\100*100) G YEARQ ; Don't compile for future months.
125 ;
126 ; - If YEARLY Average has already been calculated -> QUIT
127 I '$G(IBOVRW),$P($G(^IBE(356.19,IBYRMO,1)),"^",14)'="" Q
128 ;
129 ; - Initialize the array IBAVG for Institutional and Professional
130 F X="I","P" D
131 . S (IBAVG("$AMNT-"_X),IBAVG("BILLS-"_X),IBAVG("EPISD-"_X))=0
132 ;
133 ; Sets IBGMON with the 1st day of month 1 year prior to IBYRMO
134 S IBGMON=IBYRMO-9999,SUBCNT=0
135 F I=1:1:12 S IBTMON=IBGMON\100*100 Q:IBTMON'<IBYRMO D
136 . S X=$G(^IBE(356.19,IBTMON,1))
137 . S IBAVG("BILLS-I")=IBAVG("BILLS-I")+$P(X,U)
138 . S IBAVG("$AMNT-I")=IBAVG("$AMNT-I")+$P(X,U,2)
139 . S IBAVG("EPISD-I")=IBAVG("EPISD-I")+$P(X,U,3)
140 . S IBAVG("BILLS-P")=IBAVG("BILLS-P")+$P(X,U,4)
141 . S IBAVG("$AMNT-P")=IBAVG("$AMNT-P")+$P(X,U,5)
142 . S IBAVG("EPISD-P")=IBAVG("EPISD-P")+$P(X,U,6)
143 . S IBGMON=$$FMADD^XLFDT(IBGMON,31),SUBCNT=SUBCNT+1
144 ;
145 I SUBCNT<6 G YEARQ ; If less than 6 months of data don't store.
146 S IBAVG("$AMNT-I")=$J(IBAVG("$AMNT-I"),0,2)
147 S IBAVG("$AMNT-P")=$J(IBAVG("$AMNT-P"),0,2)
148 D LD^IBTUBOU(2,IBYRMO) ; Add to file #356.19 entry.
149 S ^TMP($J,"IBTUBAV1",IBYRMO)=""
150 ;
151YEARQ Q
152 ;
153SEND ; - Send a mail message to the Unbilled Amounts mail group informing
154 ; which months had their data (MONTHLY & YEARLY) updated.
155 N IBCNT,IBGRP,IBDT,IBT,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,I,X
156 S XMSUB="UNBILLED AMOUNTS JOB FOR "_$$DAT2^IBOUTL(IBTIMON)
157 S IBT(1)="The background job responsible for calculating and updating MONTHLY and"
158 S IBT(2)="YEARLY Average Bill Amounts and Bill numbers for inpatient episodes has"
159 S IBT(3)="successfully completed.",IBT(4)=""
160 S IBCNT=5,IBDT=0
161 F S IBDT=$O(^TMP($J,"IBTUBAV",IBDT)) Q:'IBDT D
162 . S IBT(IBCNT)="Monthly totals calculated for "_$$DAT2^IBOUTL(IBDT)
163 . S IBCNT=IBCNT+1
164 S IBT(IBCNT)="",IBCNT=IBCNT+1,IBDT=0
165 F S IBDT=$O(^TMP($J,"IBTUBAV1",IBDT)) Q:'IBDT D
166 . S IBT(IBCNT)="Yearly totals calculated for "_$$DAT2^IBOUTL(IBDT)
167 . S IBCNT=IBCNT+1
168 S IBT(IBCNT)="" D SEND^IBTUBUL
169 ;
170 Q
171 ;
172ADD(IBYRMO) ; - Add entry to file 356.19 (unbilled amounts file).
173 ; Input: IBYRMO=date/time in month year format no days allowed
174 ; Output: IBADD=1-entry or entry added, 0-not added or error
175 N IBADD,DA,DD,DIC,DIE,DO,DR,Y S IBADD=0
176 I IBYRMO'?7N!($E(IBYRMO,6,7)'="00") G ADDQ
177 I $D(^IBE(356.19,IBYRMO,0)) S IBADD=1 G ADDQ
178 S DIC="^IBE(356.19,",DIC(0)="L",DLAYGO=356.19
179 L +^IBE(356.19,IBYRMO):0
180 I $T S (DINUM,X)=IBYRMO D FILE^DICN I +Y>0 S IBADD=1
181 L -^IBE(356.19,IBYRMO)
182 ;
183ADDQ Q IBADD
Note: See TracBrowser for help on using the repository browser.