source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAMTS2.m

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IBAMTS2 ;ALB/CPM - PROCESS UPDATED OUTPATIENT ENCOUNTERS ; 25-AUG-93
2 ;;2.0;INTEGRATED BILLING;**52,91,117,132,153,156,167,247,339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5UPD ; Perform encounter update actions.
6 N IBCBK,IBFILTER,IBVAL
7 ;
8 ; - was check out deleted?
9 I IBAST'=2,IBBST=2 S IBCRES=$S(IBAST=8:5,1:1)
10 ;
11 ; - see if checked out appt classifications were changed
12 I IBAST=2,IBBST=2 D CLSF^IBAMTS1(1,.IBCLSF) S IBACT=$$CLUPD() G:'IBACT UPDQ D I IBACT'=1 G UPDQ
13 .I IBACT=1 S IBCRES=2 Q
14 .I IBACT=2 N IBCLSF D NEW^IBAMTS1
15 ;
16 ; - cancel charge if there is a cancellation reason, and the billed
17 ; - charge was for the appointment that is no longer billable
18 I '$G(IBCRES) G UPDQ
19 I '$$LINK(IBOE,$S(IBEVT:IBEVT,1:IBEV0),IBBILLED) G UPDQ
20 D CANC G:IBY<0 UPDQ
21 ;
22 ; - look for other billable visits if Means Test billable
23 I '$$BIL^DGMTUB(DFN,IBDT) G UPDQ
24 S IBBILLED=0
25 ;
26 S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDAT-.1,IBVAL("EDT")=IBDAT_.99
27 S IBFILTER=""
28 ; Skip encounter just cancelled,
29 ; consider only parent encounters, appts checked out
30 S IBCBK="I Y'=IBOE,'$P(Y0,U,6),$P(Y0,U,12)=2 D BEDIT^IBAMTS2(Y,Y0) S:IBBILLED SDSTOP=1"
31 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
32 ;
33UPDQ K IBCLSF,IBACT,IBC,IBOEN,IBEVT
34 Q
35 ;
36BEDIT(IBOEN,IBEVT) ; - perform batch edit
37 I $P(IBEVT,U,10)=1 S UNBILLED=1 Q ; C&P exam -- stop looking
38 S IBORG=+$P(IBEVT,U,8),IBAPTY=+$P(IBEVT,U,10)
39 I IBORG=3 S IBDISP=+$$DISND^IBSDU(IBOEN,IBEVT,7) Q:'IBDISP
40 Q:'$$CHKS^IBAMTS1
41 ;
42 ; - check classifications
43 S IBCLSF=$$ENCL(IBOEN)
44 I IBCLSF[1 Q ; care was related to ao/ir/swa/sc/mst/hnc/cv/shad
45 S IBSL="409.68:"_IBOEN ; set softlink
46 ;
47 ; - ready to bill another encounter
48 D BLD^IBAMTS1 S IBBILLED=1
49 Q
50 ;
51CRES ; List of cancellation reasons
52 ;;CHECK OUT DELETED
53 ;;CLASSIFICATION CHANGED
54 ;;MT OP APPT NO-SHOW
55 ;;MT OP APPT CANCELLED
56 ;;RECD INPATIENT CARE
57 ;;BILLED AT HIGHER TIER RATE
58 ;
59LINK(IBOE,IBEVT,IBN) ; Was the billed charge for the current appointment?
60 ; Input: IBOE -- Pointer to outpatient encounter in file #409.68
61 ; IBEVT -- Zeroth node of encounter in file #409.68
62 ; IBN -- Pointer to charge in file #350
63 ; Output: 0 -- Charge was not for current appointment
64 ; 1 -- Charge was for current appointment
65 N IBSL,Y
66 I '$G(IBOE)!'$G(IBEVT)!'$G(IBN) G LINKQ
67 S IBSL=$P($G(^IB(IBN,0)),"^",4)
68 I +IBSL=44 S Y=$P(IBSL,";",1,2)=("44:"_$P(IBEVT,"^",4)_";S:"_+IBEVT) G LINKQ
69 I +IBSL=409.68 S Y=IBSL=("409.68:"_IBOE)
70LINKQ Q +$G(Y)
71 ;
72CLUPD() ; Examine changes in the classification.
73 ; Output: 0 -- no changes
74 ; 1 -- changes require charges to be cancelled
75 ; 2 -- changes require appt to be billed
76 ; 3 -- [ec/swa] cancel charge, create deferred charge
77 ; 4 -- [ec/swa] pass deferred charge, disposition case
78 N I,Y S Y=0
79 I IBCLSF("BEFORE")=IBCLSF("AFTER") G CLUPDQ
80 F I=1,2,3,4,5,6,7,8 I '$P(IBCLSF("BEFORE"),U,I),$P(IBCLSF("AFTER"),U,I) S Y=$S(I=4:3,1:1) G CLUPDQ
81 F I=1,2,3,4,5,6,7,8 I $P(IBCLSF("BEFORE"),U,I),'$P(IBCLSF("AFTER"),U,I) S Y=$S(I=4:4,1:2) Q
82CLUPDQ Q Y
83 ;
84CANC ; Determine cancellation reason and cancel charge
85 ; Input variables: IBCRES -- Code for reason to be determined
86 ; IBBILLED -- Charge to be cancelled
87 S IBCRES=$P($T(CRES+IBCRES),";;",2),IBCRES=+$O(^IBE(350.3,"B",IBCRES,0))
88 D CANCH^IBECEAU4(IBBILLED,IBCRES)
89 Q
90 ;
91ENCL(IBOE) ; Return classification results for an encounter.
92 ; Input: IBOE -- Pointer to outpatient encounter in file #409.68
93 ; Output: ao^ir^sc^swa^mst^hnc^cv^shad, where, for each piece,
94 ; 1 - care was related to condition, and
95 ; 0 (or null) - care not related to condition
96 N CL,CLD,X,Y S Y=""
97 S CL=0 F S CL=$O(^SDD(409.42,"OE",+$G(IBOE),CL)) Q:'CL S CLD=$G(^SDD(409.42,CL,0)) I CLD S $P(Y,U,+CLD)=+$P(CLD,U,3)
98 Q Y
Note: See TracBrowser for help on using the repository browser.