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

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

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1IBAMTD ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE ;21-OCT-91
2V ;;2.0;INTEGRATED BILLING;**45,52,93,115,132,153,164,156,234,312,339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 I $G(DGPMA)="",$G(DGPMP)="" Q
6 ;
7EN ; Process events from the Movement Event Driver.
8 ;
9 ;S XRTL=$ZU(0),XRTN="IBAMTD-1" D T0^%ZOSV ;start rt clock
10 ;
11 Q:+$$SWSTAT^IBBAPI() ;IB*2.0*312
12 ;
13 ; -- add admissions to claims tracking
14 D INP^IBTRKR
15 ;
16 ; -- update Transfer Pricing
17 D ^IBATEI
18 ;
19 ; -- check for Long Term Care
20 N IBALTC D EN^IBAECI Q:IBALTC
21 ;
22 ; - process billing for CHAMPVA patients
23 I $$CVA^IBAUTL5(DFN) D PROC^IBACVA G END
24 ;
25 ; - unflag continuous patients
26 S IBASIH=$$ASIH^IBAUTL5(DGPMA)
27 I DGPMP="",($P(DGPMA,"^",2)=3!(IBASIH)),$O(^IBE(351.1,"B",DFN,0)),$D(^IBE(351.1,+$O(^(0)),0)),'$P(^(0),"^",2) D UNFLAG^IBAMTD1
28 ;
29 ; - update case record on discharge for special inpatient episodes
30 S IBA=$P($S(DGPMA="":DGPMP,1:DGPMA),"^",14)
31 I $O(^IBE(351.2,"AC",IBA,0)),DGPMP="",($P(DGPMA,"^",2)=3!(IBASIH)) D DIS^IBAMTI(IBA) G END
32 ;
33 ; - quit if patient was last Means Test copay patient before adm. date
34 S IBLC=$$BILST^DGMTUB(DFN) G:'IBLC END I DGPMA="",$P(DGPMP,"^",2)=1,IBLC<$P(+DGPMP,".") G END
35 D ORIG^IBAMTC I IBLC<$P(IBADMDT,".") G END
36 ;
37 ; - if editing or deleting a movement, send bulletin; delete
38 ; case record in #351.2 for deleted admissions
39 I DGPMP]"" S IBJOB=3 D G END
40 .D ^IBAMTBU
41 .I DGPMA="",$P(DGPMP,"^",2)=1,$O(^IBE(351.2,"AC",IBA,0)) S DA=$O(^(0)),DIK="^IBE(351.2," D ^DIK K DA,DIK
42 ;
43 ; - add a case record for admission of special (ao/ir/swa/mst/hnc/shad/cv) inpatients
44 I $P(DGPMA,"^",2)=1 D G END
45 .N IBCLSF D CL^IBACV(DFN,IBADMDT,"",.IBCLSF)
46 .S IBCLSF=$O(IBCLSF(0)) I IBCLSF,(IBCLSF<5) D ADM^IBAMTI(DFN,IBA,IBCLSF) Q
47 .I $P($$GETSTAT^DGMSTAPI(DFN,IBADMDT),U,2)="Y" S IBCLSF=5,IBCLSF(5)="" D ADM^IBAMTI(DFN,IBA,IBCLSF) Q
48 .I IBCLSF=6 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; hnc
49 .I IBCLSF=8 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; shad
50 .I IBCLSF=7 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; CV has the lowest priority
51 ;
52 ; - if adding a retro-active transfer or spec. transfer, send bulletin
53 I ($P(DGPMA,"^",2)=2!($P(DGPMA,"^",2)=6)),+DGPMA<DT S IBJOB=6 D ^IBAMTBU
54 ;
55 ; - process discharges and ASIH movements only
56 I $P(DGPMA,"^",2)'=3,'IBASIH G END
57 ;
58 W:'$G(DGQUIET) !,"Billing Means Test charges...."
59 S (IBY,Y)=1,IBEVOLD=0,IBJOB=2,IBWHER=1,IBDISDT=+DGPMA\1,IBAFY=$$FY^IBOUTL(DT)
60 D SITE^IBAUTL I Y<1 S IBY=Y G END1
61 D SERV^IBAUTL2 G:IBY<1 END1
62 S IBWHER=24 D CLOCK^IBAUTL3 G:IBY<1 END1
63 ;
64 ; - Create an Outpat Copay for discharge with Observation Speciality
65 I $$MVT^DGPMOBS(IBA) D OBS^IBECEAU5 G:IBY<1 END1 G END
66 ;
67 ; - handle the variations on the basis of the event record
68 D EVFIND^IBAUTL3 ; sets IBEVDA to IEN of event record, or to 0 if none
69 S IBWHER=25 D @$S(IBEVDA:"EVT",1:"NOEVT")
70 ;
71 ; - kill variables and close
72END1 I IBY<1 S IBDUZ=DUZ D ^IBAERR1 K IBDUZ
73 W:'$G(DGQUIET) "completed."
74END D KILL1^IBAMTC
75 ;
76 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTD" D T1^%ZOSV ;stop rt clock
77 ;
78 Q
79 ;
80EVT ; Billable admission event on record.
81 ; I +$$MVT^DGPMOBS(IBA) S IBDT=IBDISDT D OE^IBAMTBU1,CLOSE1 G EVTQ
82 I IBEVCAL'<IBDISDT S IBY="-1^IB033" G EVTQ
83 I IBEVCAL S X1=IBEVCAL,X2=1 D C^%DTC S IBBDT=%H I X=IBDISDT S IBDT=IBEVCAL D PASS^IBAUTL5,CLOSE1:IBY>0 G EVTQ
84 I 'IBEVCAL S X=IBEVDT D H^%DTC S IBBDT=%H
85 S X=IBDISDT D H^%DTC S IBEDT=%H-1
86 I IBCLDA S %H=IBBDT D YMD^%DTC S IBDT=X D COUNT
87 D ^IBAUTL4,CLOSE:IBY>0
88EVTQ Q
89 ;
90NOEVT ; No billable event on record since admission date.
91 ; I +$$MVT^DGPMOBS(IBA) W:'$G(DGQUIET) " patient not billed (adm. for O&E)... " G NOEVTQ ; admitted for Observation & Examination
92 S (IBCUR,VAIP("D"))=+$G(^DGPM(IBA,0)) D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8))
93 I 'IBASIH,'IBBS G NOEVTQ ; not in billable bedsection
94 I 'IBASIH,IBCUR\1=IBDISDT S IBDT=IBDISDT D:IBBS ^IBAMTD1 G NOEVTQ
95 S X=IBADMDT\1 D H^%DTC S IBBDT=%H
96 I IBASIH S VAIP("D")=IBADMDT,IBSAVBS=IBBS D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)) I 'IBBS S X=IBCUR D H^%DTC S IBBDT=%H I IBCUR\1=IBDISDT S IBDT=IBDISDT,IBBS=IBSAVBS D:IBBS ^IBAMTD1 G NOEVTQ
97 D LAST^IBAUTL5
98 S X=IBDISDT D H^%DTC S IBEDT=%H-1
99 I IBCLDA S %H=IBBDT D YMD^%DTC S IBDT=X D COUNT
100 D ^IBAUTL4,CLOSE:IBY>0
101NOEVTQ Q
102 ;
103COUNT ; Find number of days on clock. Input: IBDT
104 S X1=IBDT,X2=IBCLDT D ^%DTC S IBCLCT=X Q
105 ;
106CLOSE ; Close out charges, events; update clocks (at discharge: tag CLOSE1)
107 I $G(IBCHPDA) S IBNOS=IBCHPDA D FILER^IBAUTL5 G:IBY<1 CLOSEQ
108 I $G(IBCHCDA) S IBNOS=IBCHCDA D FILER^IBAUTL5 G:IBY<1 CLOSEQ
109 I IBCLDA D CLUPD^IBAUTL3
110CLOSE1 I IBEVDA,$D(IBDT) S IBEVCLD=IBDT D EVCLOSE^IBAUTL3
111CLOSEQ Q
Note: See TracBrowser for help on using the repository browser.