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

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

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1IBEMTO ;ALB/CPM-BILL MT CHARGES AWAITING NEW COPAY RATE ;02-AUG-93
2 ;;2.0;INTEGRATED BILLING;**179,183,202**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Bill MT OPT charges on hold awaiting the new copay rate.
6 ;
7ENO ; Standalone option entry point
8 S IBOPT=1
9 ;
10ENR ; Enter/edit billing rates entry point
11 ;
12 ; - quit if job has been fired up from enter/edit rates already
13 I $G(IBRUN) G ENQ
14 ;
15 ; no longer used (at least for now)
16 W !!,"This option is no longer available.",! G ENQ
17 ;
18 ; - quit if there are no charges on hold awaiting the new rate
19 I '$D(^IB("AC",20)) W:$G(IBOPT) !!,"There are no charges on hold awaiting the entry of the new copay rate." G ENQ
20 ;
21 ; - quit if current rate is still too old
22 S IBDT=DT,IBX="O" D TYPE^IBAUTL2
23 I $$OLDRATE^IBAMTS1(IBRTED,DT) D:$G(IBOPT) G ENQ
24 .W !!,"The current copay rate (effective ",$$DAT1^IBOUTL(IBRTED),") is still too old to use. Please be"
25 .W !,"sure that you have entered the most current rate in your Billing Rates table."
26 ;
27 ; - if x-ref is locked, the job must be currently running
28 L +^IB("AC",20):5 E D:$G(IBOPT) G ENQ
29 .W !!,"The list of held charges cannot be accessed -- the job to bill these held"
30 .W !,"charges may currently be running."
31 ;
32 ; - queue the job to bill the held charges?
33 I '$G(IBOPT) D
34 .W !!?28,*7,*7,"*** PLEASE NOTE ***"
35 .W !?8,"The Means Test Outpatient Copayment rate has just been updated,"
36 .W !?8,"and there are charges 'on hold' awaiting the entry of this new rate!",!
37 ;
38 I $G(IBOPT) D
39 .S IBN=0 F IBJ=0:1:21 S IBN=$O(^IB("AC",20,IBN)) Q:'IBN
40 .W !!,"There ",$S(IBJ=1:"is 1",1:"are "_$S(IBJ>20:"at least ",1:"")_IBJ)," charge",$E("s",IBJ>1)," on hold, awaiting the new copay rate."
41 S DIR(0)="Y",DIR("A")="Do you want to queue a job to automatically bill these held charges",DIR("?")="^D HQ^IBEMTO"
42 D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G ENQ
43 ;
44 ; - queue up job to bill held charges
45 S:'$G(IBOPT) ZTDTH=$H
46 S ZTRTN="DQ^IBEMTO",ZTIO="",ZTDESC="BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE"
47 S IBRUN=1 D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job!")
48 ;
49ENQ L -^IB("AC",20)
50 K:$G(IBOPT) IBRUN
51 K IBN,IBDT,IBATYP,IBDESC,IBJ,IBOPT,IBRTED,IBCHG,IBX,ZTSK
52 Q
53 ;
54HQ ; Help for prompt
55 W !!,"If you wish to queue off a job to bill the Means Test Outpatient"
56 W !,"copayment charges that are on hold awaiting entry of the updated"
57 W !,"billing rate, please enter 'Y' or 'YES'. The job will be tasked"
58 W !,"immediately. Otherwise, enter 'N' or 'NO' or '^' to quit."
59 Q
60 ;
61 ;
62DQ ; Tasked job to bill all charges awaiting the new copay rate.
63 S IBJOB=8,IBDUZ=DUZ,IBSEQNO=1,IBCNT=0
64 ;
65 ; - record start time
66 D NOW^%DTC S IBSTART=$$DAT2^IBOUTL(%)
67 ;
68 ; - if can't lock x-ref, job must currently be running
69 L +^IB("AC",20):5
70 ;
71 ; - loop through all charges awaiting the new rate
72 I S IBREF=0 F S IBREF=$O(^IB("AC",20,IBREF)) Q:'IBREF D CHG
73 ;
74 ; - unlock x-ref, record end time, and post bulletin
75 L -^IB("AC",20)
76 D NOW^%DTC S IBEND=$$DAT2^IBOUTL(%)
77 D BULL^IBEMTO1
78 K IBT,IBSTART,IBEND,IBREF,IBND,IBDT,IBX,IBCHG,IBSEQNO,IBNOS,IBCNT,XMTEXT,XMSUB,XMZ,XMY,XMDUZ
79 Q
80 ;
81CHG ; Pass a single charge to Accounts Receivable.
82 S IBND=$G(^IB(IBREF,0)) I 'IBND K ^IB("AC",20,IBREF) G CHGQ
83 S IBDT=DT,IBX="O" D TYPE^IBAUTL2
84 I $$OLDRATE^IBAMTS1(IBRTED,$P(IBND,"^",14)) G CHGQ ; rate still old
85 S $P(^IB(IBREF,0),"^",7)=IBCHG,IBSEQNO=1,DFN=+$P(IBND,"^",2)
86 S IBNOS=IBREF D ^IBR S:Y>0 IBCNT=IBCNT+1
87CHGQ Q
Note: See TracBrowser for help on using the repository browser.