source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAMTI.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: 5.2 KB
Line 
1IBAMTI ;ALB/CPM - SPECIAL INPATIENT BILLING CASES ; 11-AUG-93
2 ;;2.0;INTEGRATED BILLING;**52,132,153,156,234,247,339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ADM(DFN,IBPM,IBCL) ; Create a new case record upon admission
6 ; Input: DFN -- Pointer to the patient in file #2
7 ; IBPM -- Pointer to the adm movement in file #405
8 ; IBCL -- Patient class [1-ao|2-ir|3-sc|4-swa|5-mst|6-hnc|7-cv|8-shad]
9 I '$G(DFN)!'$G(IBPM)!'$G(IBCL) G ADMQ
10 N DA,DIC,DIE,DR,IBC,X,Y
11 ;
12 ; - need to swap the input of 3 (SC) to 4, and 4 (EC) to 3
13 S IBCL=$S(IBCL=3:4,IBCL=4:3,IBCL=5:5,1:IBCL)
14 ;
15 K DD,DO S DIC="^IBE(351.2,",DIC(0)="",X=DFN D FILE^DICN S IBC=+Y
16 S DR=".02////"_IBPM_";.03////"_IBCL_";.05////1;2.01////"_DUZ_";2.02///NOW;2.03////"_DUZ_";2.04///NOW"
17 S DA=IBC,DIE=DIC D ^DIE
18 D BULL(1,IBCL) ; send admission bulletin
19ADMQ Q
20 ;
21DIS(IBPM) ; Update the case record upon discharge
22 ; Input: IBPM -- Pointer to the adm movement in file #405
23 N DA,DIE,DR,IBC
24 S IBC=$O(^IBE(351.2,"AC",+$G(IBPM),0)) I 'IBC G DISQ
25 S DR=".05////2;.06////"_DT_";2.03////"_DUZ_";2.04///NOW"
26 S DA=IBC,DIE="^IBE(351.2," D ^DIE
27 D BULL(2,+$P($G(^IBE(351.2,IBC,0)),"^",3)) ; send discharge bulletin
28DISQ Q
29 ;
30BGJ ; Perform nightly background monitoring of all case records.
31 N IBC,IBCD,IBNUM
32 S IBC=0 F S IBC=$O(^IBE(351.2,IBC)) Q:'IBC S IBCD=$G(^(IBC,0)) D
33 .Q:$P(IBCD,"^",8) ; case has been dispositioned
34 .Q:$P(IBCD,"^",5)=1 ; patient still admitted
35 .I '$P(IBCD,"^",6) S $P(^IBE(351.2,IBC,0),"^",6)=DT Q ; no disch date
36 .S IBNUM=$$FMDIFF^XLFDT(DT,$P(IBCD,"^",6))
37 .Q:IBNUM<45 ; still time to disposition the case
38 .D NOTICE(IBNUM,+IBCD,+$P(IBCD,"^",2),+$P(IBCD,"^",3)) ; send reminder to disposition
39 Q
40 ;
41BULL(IBEV,IBCL) ; Send a bulletin at admission and discharge.
42 ; Input: IBEV -- Event [1:admission|2:discharge]
43 ; IBCL -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
44 K IBT S IBPT=$$PT^IBEFUNC(DFN)
45 S XMSUB=$E($P(IBPT,"^"),1,14)_" "_$P(IBPT,"^",3)_" - "_$$UCCL(IBCL)_$S($G(IBEV)=1:" ADM",1:" DISCH")
46 S IBT(1)="The following Means Test copay "_$$LCCL(IBCL)_" patient was just "_$S($G(IBEV)=1:"admitted:",1:"discharged:")
47 S IBT(2)=" " S IBC=2
48 S IBDUZ=DUZ D PAT^IBAERR1
49 S IBC=IBC+1,IBT(IBC)=" "
50 S IBC=IBC+1,IBT(IBC)=$S($G(IBEV)=1:"Please note that a special inpatient case record has been created for",1:"Please note that you have 45 days to determine if this episode of care")
51 S IBC=IBC+1,IBT(IBC)=$S($G(IBEV)=1:"this admission.",1:"should be billed.")
52 ;---CV
53 I IBCL=7,$G(IBEV)=2 D
54 . N Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS
55 . S (Y,X,IBZ,IBFL,IBEXP,IBTODAY,IBDIS)=0
56 . D NOW^%DTC S IBTODAY=%\1
57 . S IBZ=$$CVEDT^IBACV(DFN,IBTODAY)
58 . I +IBZ=1 Q ;patient is still CV
59 . S IBEXP=+$P(IBZ,"^",2)\1
60 . S IBDIS=+$G(^DGPM(+$P($G(^DGPM(+$G(IBPM),0)),"^",17),0))\1
61 . ; if CV expired during inpatient stay
62 . I IBDIS>0,IBEXP'>IBDIS D
63 . . S IBFL=1
64 . . S Y=IBEXP D DD^%DT S IBEXP=Y
65 . . S IBC=IBC+1,IBT(IBC)=""
66 . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient's CV status has expired on "_IBEXP_" during the"
67 . . S IBC=IBC+1,IBT(IBC)="inpatient stay. Billing needs to be adjusted accordingly."
68 . ; if discharge move was entered after actual discharge date
69 . I IBFL=0 D
70 . . S Y=IBEXP D DD^%DT S IBEXP=Y
71 . . S IBC=IBC+1,IBT(IBC)=""
72 . . S IBC=IBC+1,IBT(IBC)="WARNING: Patient CV status has expired on "_IBEXP_""
73 ;---
74 I IBEV=2 D
75 .I '$$BIL^DGMTUB(DFN,DT) S IBC=IBC+1,IBT(IBC)=" ",IBC=IBC+1,IBT(IBC)="Note: This patient, who was MT copay at admission, is no longer MT billable."
76 .I $$BFO^IBECEAU(DFN,+$G(^DGPM(IBPM,0))\1) S IBC=IBC+1,IBT(IBC)=" ",IBC=IBC+1,IBT(IBC)="Note: This patient was billed the outpatient copayment at admission."
77 D SEND^IBACVA2
78 Q
79 ;
80NOTICE(IBNUM,DFN,IBPM,IBCL) ; Notice to disposition billing case
81 ; Input: IBNUM -- Number of days since discharge
82 ; DFN -- Pointer to the patient in file #2
83 ; IBPM -- Pointer to the admission in file #405
84 ; IBCL -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
85 ;
86 Q:IBNUM#15 ; send notice every 15 days only
87 N IBC K IBT S IBPT=$$PT^IBEFUNC(DFN)
88 S XMSUB="NOTICE TO DISPOSITION SPECIAL INPATIENT BILLING CASE"
89 S IBT(1)="The case record for this Means Test copay "_$$LCCL(IBCL)_" patient"
90 S IBT(2)="is now "_IBNUM_" days old and should be dispositioned:"
91 S IBT(3)=" " S IBC=3
92 S IBDUZ=DUZ D PAT^IBAERR1
93 S Y=+$G(^DGPM(+$G(IBPM),0)) D DD^%DT
94 S IBC=IBC+1,IBT(IBC)=" Adm Date: "_Y
95 S Y=+$G(^DGPM(+$P($G(^DGPM(+$G(IBPM),0)),"^",17),0)) D DD^%DT
96 S IBC=IBC+1,IBT(IBC)="Disc Date: "_Y
97 S IBC=IBC+1,IBT(IBC)=" "
98 S IBC=IBC+1,IBT(IBC)="Please determine if this episode of care should be billed, and use"
99 S IBC=IBC+1,IBT(IBC)="the Cancel/Edit/Add Patient Charges option to add charges, or the"
100 S IBC=IBC+1,IBT(IBC)="Disposition Special Inpatient Billing Cases option to enter the reason"
101 S IBC=IBC+1,IBT(IBC)="for not billing."
102 D SEND^IBACVA2
103 Q
104 ;
105UCCL(X) ; Return the upper case classification description.
106 ; Input: X -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
107 Q $S('$G(X):"SPECIAL",1:$$PATTYPE^IBACV(X))
108 ;
109LCCL(X) ; Return the lower case classification description.
110 ; Input: X -- Patient class [1-ao|2-ir|3-swa|4-sc|5-mst|6-hnc|7-cv|8-shad]
111 Q $S('$G(X):"Special",1:$$PATTYPE^IBACV(X,"M"))
112 ;
Note: See TracBrowser for help on using the repository browser.