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

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1IBAMTEDU ;ALB/CPM - MEANS TEST BULLETIN UTILITIES ; 15-JUN-93
2 ;;2.0;INTEGRATED BILLING;**15,91,153**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CHG(IBDAT) ; Any charges billed on or after IBDAT?
6 ; Input: IBDAT -- Date on or after which charges have been billed
7 ; Output: 0 -- No charges billed
8 ; 1 -- Charges were billed; IBARR contains array
9 ; of those charges
10 N IBFND,IBD,IBN,IBX,IBJOB,IBWHER K IBARR
11 ;
12 ; - if the effective date of the test is today, cancel today's charges.
13 I $P(IBDAT,".")=DT D CANC G CHGQ
14 ;
15 ; - find all charges which may need to be cancelled.
16 S IBX="" F S IBX=$O(^IB("AFDT",DFN,IBX)) Q:'IBX S IBD=0 F S IBD=$O(^IB("AFDT",DFN,IBX,IBD)) Q:'IBD D
17 .I $P($G(^IB(IBD,0)),"^",8)'["ADMISSION" D:-IBX'<IBDAT CHK(IBD) Q
18 .S IBN=0 F S IBN=$O(^IB("AF",IBD,IBN)) Q:'IBN D CHK(IBN)
19CHGQ Q +$G(IBFND)
20 ;
21CHK(IBN) ; Place charge into the array.
22 ; Input: IBN -- Charge to check
23 N IBND,IBNDL,IBLAST
24 S IBND=$G(^IB(IBN,0)) I $P(IBND,"^",15)<IBDAT G CHKQ
25 S IBLAST=$$LAST^IBECEAU(+$P(IBND,"^",9)),IBNDL=$G(^IB(+IBLAST,0))
26 I $P($G(^IBE(350.1,+$P(IBNDL,"^",3),0)),"^",5)'=2,"^1^2^3^4^8^20^21^"[("^"_$P(IBNDL,"^",5)_"^") S IBARR(+$P(IBNDL,"^",14),IBLAST)="",IBFND=1
27CHKQ Q
28 ;
29CANC ; Cancel any charges for the patient for today.
30 N IBD,IBN,IBCRES,IBFAC,IBSITE,IBSERV,IBDUZ
31 Q:'$$CHECK^IBECEAU
32 S IBCRES=+$O(^IBE(350.3,"B","MT STATUS CHANGED FROM YES",0))
33 S:'IBCRES IBCRES=22 S IBJOB=7,IBWHER=30,IBDUZ=DUZ
34 S IBD=0 F S IBD=$O(^IB("AFDT",DFN,-DT,IBD)) Q:'IBD D
35 .I $P($G(^IB(IBD,0)),"^",8)'["ADMISSION" D CANCH^IBECEAU4(IBD,IBCRES,1) Q
36 .S IBN=0 F S IBN=$O(^IB("AF",IBD,IBN)) Q:'IBN D CANCH^IBECEAU4(IBN,IBCRES,1)
37 Q
38 ;
39 ;
40EP(IBDAT) ; Any billable episodes of care since IBDAT?
41 ; Input: IBDAT -- Date on or after which patient received care
42 ; Output: 0 -- No billable episodes found
43 ; 1 -- Billable episodes were found; IBARR contains an
44 ; array of those episodes
45 ;
46 N IBD,IBAD,IBNOW,IBEP,IBDT,IBI,IBPM,VA,VAIP,VAERR,IBVAL,IBCBK,IBZ,IBPB
47 ;
48 ; - quit if the effective date of the test is today
49 I $P(IBDAT,".")=DT G EPQ
50 ;
51 ; - find scheduled visits, stand-alone encounters and dispositions
52 ; on or after IBDAT from the outpatient encounters file
53 D NOW^%DTC S IBNOW=%
54 K IBARR,^TMP("IBOE",$J)
55 S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDAT,IBVAL("EDT")=IBNOW
56 ;Consider only parent encounters
57 S IBFILTER=""
58 S IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,Y)=Y0"
59 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
60 F IBZ=0,1,2,9,13 S IBCK(IBZ)=""
61 S IBOE=0 F S IBOE=$O(^TMP("IBOE",$J,IBOE)) Q:'IBOE S IBOE0=$G(^(IBOE)) D
62 . K IBPB
63 . S IBEP=$$BILLCK(IBOE,IBOE0,.IBCK,.IBPB)
64 . S IBZ=0 F S IBZ=$O(IBPB(IBZ)) Q:'IBZ D
65 .. I IBZ=1 S IBARR(+IBOE0,"APP")=$P(IBOE0,U,4)_U_$P(IBOE0,U,10)
66 .. I IBZ=2 S IBARR(IBOE0\1,"SC"_IBOE)=$P(IBOE0,U,3)_U_$P(IBOE0,U,10)
67 .. I IBZ=3 S IBARR(+IBOE0,"R")=$P(IBPB(3),U,7)
68 K ^TMP("IBOE",$J)
69 ;
70 ; - find admissions since IBDAT
71 S VAIP("D")=IBDAT D IN5^VADPT I VAIP(13) S IBPM=$G(^DGPM(+VAIP(13),0)),IBARR(+IBPM,"ADM")=$P(IBPM,"^",6),IBEP=1
72 S IBD="" F S IBD=$O(^DGPM("ATID1",DFN,IBD)) Q:'IBD!(9999999.999999-IBD<IBDAT) S IBPM=$G(^DGPM(+$O(^(IBD,0)),0)),IBARR(+IBPM,"ADM")=$P(IBPM,"^",6),IBEP=1
73 ;
74EPQ Q +$G(IBEP)
75 ;
76BILLCK(IBOE,IBOE0,IBCK,IBPB) ; Check for potentially billable outpt enctr
77 ; IBOE = encounter ien in file 409.68
78 ; IBOE0 = encounter 0-node
79 ; IBCK = array subscriptd by # that, if defined, specifies edit to check
80 ; and exclude if it doesn't pass it
81 ; (0) = check if pt claimed exposure
82 ; (1) = check if non-billable appt type for means test
83 ; (2) = check if non-count clinic
84 ; (3) = check if non-billable clinic
85 ; (4) = check if pt not Means Test copay pt
86 ; (5) = check if pt admitted by midnight same date
87 ; (6) = check if C&P exam same date
88 ; (7) = check if non-billable stop code (third party)
89 ; (8) = check if non-billable stop code (auto-biller)
90 ; (9) = check if disposition and application without exam
91 ; (10) = check if non-billable disposition
92 ; (11) = check if service connected (ck parent only)
93 ; (12) = check if non-billable clinic
94 ; (13) = check if appt status is set (cancelled/noshow/inpt/etc)
95 ; (13.1) = same as (13) except don't exclude if encounter status is non-count
96 ; (14) = check if non-billable appt type for report
97 ; Returns IBPB = the # of the edit that failed
98 ; IBPB(1) = "" if valid appt
99 ; IBPB(2) = "" if valid add/edit stop code
100 ; IBPB(3) = 0-node of disposition file entry if valid disp
101 ; Function returns true if potentially billable or false if not
102 N DFN,IBAD,IBD,IBSRCE,QUIT
103 S DFN=$P(IBOE0,U,2),IBSRCE=$P(IBOE0,U,8),IBD=IBOE0\1
104 I $D(IBCK(0))!($D(IBCK(11))) S QUIT=0 D G:QUIT BILLCKQ
105 . N Z
106 . I $D(IBCK(11)),$P(IBOE0,U,6) D Q:QUIT ;Check parent encounter
107 .. S Z=$$ENCL^IBAMTS2($P(IBOE0,U,6))
108 .. I $P(Z,U,3)=1 S QUIT=1,IBPB=11
109 . S Z=$$ENCL^IBAMTS2(IBOE)
110 . I $D(IBCK(0)),Z[1 S QUIT=1,IBPB=0 Q
111 . I $D(IBCK(11)),'$P(IBOE0,U,6),$P(Z,U,3)=1 S QUIT=1,IBPB=11
112 I $D(IBCK(4)),'$$BIL^DGMTUB(DFN,+IBOE0) S IBPB=4 G BILLCKQ
113 I $D(IBCK(5)),$$INPT^IBAMTS1(DFN,IBD_.2359) S IBPB=5 G BILLCKQ
114 I $D(IBCK(6)),$$CNP^IBECEAU(DFN,IBD) S IBPB=6 G BILLCKQ
115 ;
116 ; - Appointment or stop code
117 I "12"[IBSRCE D G BILLCKQ
118 . I $D(IBCK(13))!($D(IBCK(13.1))),IBSRCE=1 D Q:$G(IBPB)
119 .. I '$$APPTCT^IBEFUNC(IBOE0),$S('$D(IBCK(13.1)):1,1:$P(IBOE0,U,12)'=12) S IBPB=13
120 . I $D(IBCK(14)),$$RPT^IBEFUNC(+$P(IBOE0,U,10),IBD) S IBPB=14 Q
121 . I $D(IBCK(1)),$$IGN^IBEFUNC(+$P(IBOE0,U,10),IBD) S IBPB=1 Q
122 . I $D(IBCK(2)),$$NCTCL^IBEFUNC(IBOE) S IBPB=2 Q
123 . I $D(IBCK(3)),$$NBCL^IBEFUNC(+$P(IBOE0,U,4),IBD) S IBPB=3 Q
124 . I $D(IBCK(7)),$$NBST^IBEFUNC(+$P(IBOE0,U,3),IBD) S IBPB=7 Q
125 . I $D(IBCK(8)),$$NBCSC^IBEFUNC(+$P(IBOE0,U,3),IBD) S IBPB=8 Q
126 . I $D(IBCK(12)),$$NBCT^IBEFUNC(+$P(IBOE0,U,4),IBD) S IBPB=12 Q
127 . ;
128 . S IBPB(IBSRCE)=""
129 ;
130 ; - Disposition
131 S IBAD=$$DISND^IBSDU(IBOE,IBOE0)
132 I $D(IBCK(9)),'$$DISCT^IBEFUNC(IBOE,IBOE0) S IBPB=9 G BILLCKQ
133 I $D(IBCK(10)),$$NBDIS^IBEFUNC(+$P(IBAD,U,7),IBD) S IBPB=10 G BILLCKQ
134 S IBPB(3)=IBAD
135 ;
136BILLCKQ Q ($G(IBPB)="")
137 ;
Note: See TracBrowser for help on using the repository browser.