source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAMTC.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1IBAMTC ;ALB/CPM-MEANS TEST NIGHTLY COMPILATION JOB ;09-OCT-91
2V ;;2.0;INTEGRATED BILLING;**34,52,70,93,100,118,115,132,150,153,137,176,215,275,321,312**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INIT ; Entry point - initialize variables and parameters
6 ;
7 ;***
8 ;S XRTL=$ZU(0),XRTN="IBAMTC-1" D T0^%ZOSV ;start rt clock
9 ;
10 D UPDT^IBARXEPS($$FMADD^XLFDT(DT,-30),DT,1)
11 ;
12 D NIGHTLY^IBTRKR ; claims tracking nightly update
13 ;
14 D ^IBCD ; automated biller
15 ;
16 D RELPR^IBAMTV3 ; auto-release patient charges on hold at least 60 days
17 ;
18 D EN^IBOHRL ; auto-release patient charges on hold longer than 90 days
19 ;
20 K IBDT D BJ^IBJDE ; Automated DM extract monthly background job.
21 ;
22 ; - transfer pricing background job
23 I '+$$SWSTAT^IBBAPI() D ^IBATEI1 ;IB*2.0*312
24 ;
25 D NIGHT^IBARXMA ; transmit copay cap info
26 ;
27 D NOW^%DTC S IBAFY=$$FY^IBOUTL(X),DT=X,U="^"
28 S (IBERRN,IBWHER,IBJOB,IBY,Y)=1,IBCNT=0 K ^TMP($J,"IBAMTC")
29 D SITE^IBAUTL I Y<1 S IBY=Y D ERR G CLEAN
30 D SERV^IBAUTL2 I IBY<1 D ERR G CLEAN
31 ;
32 ; Compile Means Test copay and per diem charges for all inpatients
33 ; Check PFSS Switch ;IB*2.0*312
34 I '+$$SWSTAT^IBBAPI() S (IBWARD,DFN)="" F S IBWARD=$O(^DPT("CN",IBWARD)) Q:IBWARD="" F S DFN=$O(^DPT("CN",IBWARD,DFN)) Q:'DFN W !,DFN S IBA=^(DFN),IBY=1 D PROC
35 ;
36 ;send inpatients' CV (CombatVet) expiration e-mail alert
37 D CVEXMAIL^IBACV(DT)
38 ;
39 ;check & start LTC Monthly Job LTC if necessary
40 ; This code may need to be expanded, IF we don't ;IB*2.0*312
41 ; implement on the 1st of the month, for a clean cut over ;IB*2.0*312
42 I '+$$SWSTAT^IBBAPI() D NJ^IBAECN1 ;IB*2.0*312
43 ;
44 D EN^IBCE ; Transmit electronic bills
45 ; Clean up expired Means Test billing clocks
46CLEAN S %H=+$H-1 D YMD^%DTC S IBDT=X,(IBN,DFN)=0,IBWHER=23
47 F S DFN=$O(^IBE(351,"ACT",DFN)) Q:'DFN D
48 . F S IBN=$O(^IBE(351,"ACT",DFN,IBN)) Q:'IBN D
49 .. S IBY=1,X1=IBDT,(X2,IBCLDT)=+$P($G(^IBE(351,+IBN,0)),"^",3) D ^%DTC
50 .. I X>364 S IBCLDA=IBN D CLOCKCL^IBAUTL3,ERR:IBY<1
51 ;
52 ; Close out incomplete events where the patient has been discharged,
53 ; pass the related charges if they appear correct, and send a bulletin
54 ; - also, send bulletins on old incomplete charges where there is no
55 ; incomplete event
56 D MAIN^IBAMTC2
57 ;
58 ;D ^IBAMTC1
59 ;
60 ; Send bulletin reporting job completion
61 I '+$$SWSTAT^IBBAPI() D BULL^IBAMTC1 ;IB*2.0*312
62 ;
63 ; -- purge alerts
64 D PURGE^IBAERR3
65 ;
66 ; Monitor special inpatient billing cases
67 D BGJ^IBAMTI
68 ;
69 ; Print Pharmacy Copay Exemption Income Test Reminder Letters
70 D EN^IBARXEL
71 ;
72 ; Kill variables and quit.
73 D KILL1
74 ;
75 I $D(ZTQUEUED),$G(ZTSK) D KILL^%ZTLOAD
76 ;***
77 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTC" D T1^%ZOSV ;stop rt clock
78 ;
79 Q
80 ;
81 ;
82PROC ; Process all currently admitted patients.
83 ;
84 D IFCVEXP^IBACV(DFN,DT,IBA) ;if CV has expired (see CVEXMAIL^IBACV)
85 ;--
86 ;1) checks effective date for LTC legislation.
87 ;2) determine current treating specialty (TS) for the
88 ;"original" admission.
89 ;if TS is LTC:
90 ; - creates new LTC #350 parent event entry if necessary.
91 ;NOTE: It doesn't stop MT billing for LTC. CALC^IBAUTL4 does it.
92 I $$ISLTCADM^IBAECN1(DFN,IBA)
93 ;--
94 D ORIG ; find "original" admission date
95 Q:$$BILST^DGMTUB(DFN)<IBADMDT ; pat. was last billable before admission
96 Q:IBADMDT\1=DT ; patient was admitted today - process tomorrow
97 Q:+$$MVT^DGPMOBS(IBA) ; admitted for Observation & Examination
98 Q:$O(^IBE(351.2,"AC",IBA,0)) ; skip special inpatient admissions
99 ;
100 ; - if vet is SC, create a Special Inpatient Billing Case
101 ; in file #351.2 (use code 3 for SC, as it is changed to 4 in IBAMTI)
102 D ELIG^VADPT I VAEL(3) D ADM^IBAMTI(DFN,IBA,3) Q
103 ;
104 ; - gather event information
105 D EVFIND^IBAUTL3 I 'IBEVDA D BSEC Q:'IBBS ; wasn't billable yesterday
106 S X=IBADMDT D H^%DTC S IBBDT=%H D:'IBEVDA LAST^IBAUTL5
107 I IBEVDA,IBEVCAL S X1=IBEVCAL,X2=1 D C^%DTC S IBBDT=%H
108 S IBEDT=+$H-1
109 ; - gather clock information
110 S IBWHER=24 D CLOCK^IBAUTL3 I IBY<1 D ERR G PROCQ
111 I IBCLDA S X=IBCLDT D H^%DTC S IBCLCT=IBBDT-%H
112 ; - build charges for inpatient days
113 D ^IBAUTL4 I IBY<1 D ERR G PROCQ
114 ; - pass per diem if over 30 days old, or both per diem and the copay
115 ; - if 4 days from patient's statement date; update event, clock
116 S IBWHER=22
117 I $G(IBCHPDA),$P($G(^IB(+IBCHPDA,0)),"^",6)>30!($$STD^IBAUTL5(DFN)) S IBNOS=IBCHPDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
118 I $G(IBCHCDA),$$STD^IBAUTL5(DFN) S IBNOS=IBCHCDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
119 I IBEVDA,$D(IBDT) S IBEVCLD=IBDT D EVUPD^IBAUTL3
120 I IBCLDA D CLUPD^IBAUTL3
121PROCQ D KILL Q
122 ;
123BSEC ; Determine patient's bedsection for the previous day.
124 S X1=DT,X2=-1 D C^%DTC
125 S VAIP("D")=X_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)) Q
126 ;
127ERR ; Error processing. Input: IBY, IBWHER, IBCNT
128 S IBDUZ=DUZ,IBCNT=IBCNT+1 D ^IBAERR1 K IBDUZ Q
129 ;S ^TMP($J,"IBAMTC","E",IBERRN)=$P(IBY,"^",2)_"^"_$S($D(DFN):DFN,1:"")_"^"_IBWHER,IBERRN=IBERRN+1 Q
130 ;
131ORIG ; Find first admission date, considering ASIH movements
132 ; Input: IBA Output: IBADMDT
133 N X,Y,Z S Z=IBA
134 F S X=$G(^DGPM(Z,0)),Y=$P(X,"^",21) Q:Y="" S Z=+$P($G(^DGPM(Y,0)),"^",14)
135 S IBADMDT=+X Q
136 ;
137KILL1 ; Kill all IB variables.
138 K VAERR,VAEL,VAIP,IBA,IBADMDT,IBAFY,IBATYP,IBBDT,IBBS,IBCHARG,IBCHG,IBCNT,IBCUR,IBDESC,IBDISDT,IBDT,IBDUZ,IBFAC,IBI,IBIL,IBJOB,IBLC,IBMAX
139 K IBN,IBNOS,IBSAVBS,IBSEQNO,IBSERV,IBSITE,IBSL,IBTRAN,IBX,IBY,IBWHER,IBWARD,IBEDT,IBCHCTY,IBCHPDE,IBERRN,IBASIH,IBRTED
140KILL ; Kill all IB variables needed to build charges.
141 K IBCLCT,IBCLDA,IBCLDT,IBCLDAY,IBCLDOL,IBCHPDA,IBCHCDA,IBCHG,IBCHFR,IBCHTO,IBCHTOTL,IBBS,IBNH
142 K IBEVDA,IBEVDT,IBEVCLD,IBEVCAL,IBEVNEW,IBEVOLD,IBMED,IBTOTL,IBDESC,IBIL,IBTRAN,IBATYP,IBDATE
143 Q
Note: See TracBrowser for help on using the repository browser.