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

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1IBTUTL3 ;ALB/AAS - CLAIMS TRACKING UTILITY ROUTINE ; 21-JUN-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**32**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADDC(IBTRCDT,IBTRN) ; -- add new entry to reviews file, ibt(356.1
6 ; -- Input IBTRVDT := Review date (in internal fileman format)
7 ; IBTRN := pointer to tracking module
8 ;
9 N %DT,DD,DO,DIC,DR,DIE,DLAYGO
10 S DIC="^IBT(356.2,",DIC(0)="L",DLAYGO=356.2
11 S DIC("DR")=".19////1;.02////"_$G(IBTRN)
12 S X=IBTRCDT D FILE^DICN
13 S IBTRC=+Y,IBNEW=1
14ADDCQ Q
15 ;
16COM(IBTRCDT,IBTRN,IBX,IBTRV) ; -- add initial communication entry
17 ; -- Input IBTRCDT := Communication date (in internal fileman format)
18 ; IBTRN := pointer to tracking module
19 ; IBX := code for type of contact (if null, will compute)
20 ; IBTRV := pointer to initial review (if it exists)
21 ;
22 N X,Y,DA,DR,DIE,DIC,IBXIFN,IBNXRV
23 D ADDC(IBTRCDT,$G(IBTRN))
24 ;
25 I $G(IBX) S IBXIFN=$O(^IBE(356.11,"ACODE",+IBX,0))
26 I '$G(IBXIFN) S IBXIFN=$O(^IBE(356.11,"B",$$TYPE^IBTRC(+$G(IBTRC)),0))
27 ;
28 S DA=IBTRC,DIE="^IBT(356.2,"
29 S IBNXRV=DT
30 I IBTRCDT>$$FMADD^XLFDT(DT,7) S IBNXRV=$$FMADD^XLFDT(IBTRCDT,-7)
31 L +^IBT(356.2,+IBTRC):10 I '$T G COMQ
32 S DR=".03////"_$G(IBTRV)_";.04////"_IBXIFN_";.05////"_DFN_";.24////"_IBNXRV_";1.01///NOW;1.02////"_DUZ
33 D ^DIE K DA,DR,DIE
34 L -^IBT(356.2,+IBTRC)
35COMQ Q
36 ;
37DAY(X,X1,IBTRN) ; -- compute number of days approved for tracking id
38 ; -- if same date, difference = 1
39 ; -- input x = beginning date (required)
40 ; x1 = ending date (required)
41 ; ibtrn = (optional) if defined will compute max days for episode
42 ; and will not count discharge date
43 N DIFF,IBCDT,IBBET,IBEND,IBMAX S DIFF=0
44 I $E(X,1,7)'?7N G DAYQ
45 I 'X1 S DIFF=1 G DAYQ
46 I $E(X1,1,7)'?7N G DAYQ
47 I X,$E(X,1,7)=$E(X1,1,7) S DIFF=1 G DAYQ
48 I $G(IBTRN),$P($G(^IBT(356,+IBTRN,0)),"^",5) D
49 .S IBCDT=$$CDT^IBTODD1(IBTRN)
50 .; patch 32 changed I 'IBEND
51 .S IBBEG=+IBCDT,IBEND=+$P(IBCDT,"^",2)\1 I 'IBEND S IBEND=DT
52 .S IBMAX=$$FMDIFF^XLFDT(IBEND,IBBEG)
53 .;I X1>IBEND S X1=IBEND
54 .;I X<IBBEG S X=IBBEG
55 S DIFF=$$FMDIFF^XLFDT(X1,X) I $G(IBCDT),$G(IBTRN) I $S('$P(IBCDT,"^",2):1,X1<($P(IBCDT,"^",2)\1):1,1:0) S DIFF=DIFF+1 ;add one if not include discharge date
56 I $G(IBMAX),$P($G(IBCDT),"^",2),DIFF>IBMAX S DIFF=IBMAX
57DAYQ Q DIFF
58 ;
59SCP(DFN) ; -- is patient sc, and percent
60 N VAEL D ELIG^VADPT
61 I '$G(VAEL(3)) S Y="NO"
62 I $G(VAEL(3)) S Y=$P(VAEL(3),"^",2)_"%"
63 Q Y
64 ;
65OTB(DFN) ; -- did patient ever have other type of bill
66 N I,J,Y S Y=""
67 I '$O(^IBT(356,"ASPC",DFN,0)) G OTBQ
68 S I=""
69 F S I=$O(^IBT(356,"ASPC",DFN,I)) Q:'I D ;S J="" F S J=$O(^IBT(356,"ASPC",DFN,I,J)) Q:'J
70 .S:Y'="" Y=Y_", "
71 .S Y=$S(I=1:"TORT",I=2:"OWCP",I=3:"WORK COMP.",1:"OTHER")
72 .; -- later add ability to find bills, dates, etc
73OTBQ Q Y
74 ;
75MSG(DFN) ; -- set message for display in lower bar
76 N Y,IBSCP,IBOTB S Y=""
77 S IBSCP=$$SCP(DFN),IBOTB=$$OTB(DFN)
78 S Y="Service Connected: "_IBSCP
79 I IBOTB'="" S Y=Y_" Previous Spec. Bills: "_IBOTB
80MSGQ Q Y
81 ;
82ARRAY(IBTRC) ; -- see if other reviews have dates
83 ;
84 I '$G(IBTRC) G ARRAYQ
85 N I,IBTRN K ARRAY
86 S IBTRN=$P($G(^IBT(356.2,+IBTRC,0)),"^",2) G:'IBTRN ARRAYQ
87 S IBCNS=$P($G(^IBT(356.2,+IBTRC,0)),"^",8)
88 S I=0 F S I=$O(^IBT(356.2,"C",IBTRN,I)) Q:'I D
89 .Q:$P(^IBT(356.2,+I,0),"^",8)'=IBCNS ; must be same ins. co.
90 .I $P($G(^IBT(356.2,+I,1)),"^",8) S ARRAY=I Q ; whole admission authorized
91 .I $P($G(^IBT(356.2,+I,1)),"^",7) S ARRAY(0)=I Q ;whole admission denied
92 .I $P($G(^IBT(356.2,+I,0)),"^",12) S ARRAY(+$P(^IBT(356.2,+I,0),"^",12),+$P(^IBT(356.2,+I,0),"^",13))=I_"^"_1
93 .I $P($G(^IBT(356.2,+I,0)),"^",15) S ARRAY(+$P(^IBT(356.2,+I,0),"^",15),+$P(^IBT(356.2,+I,0),"^",16))=I_"^"_2
94ARRAYQ Q
95 ;
96HELP(IBTRC) ; -- dd help for dates authorized and denied.
97 ;
98 N ARRAY,IBCNS D ARRAY(IBTRC)
99 D WRITE
100 Q
101 ;
102WRITE ; -- write extended help
103 ;
104 Q:$D(ZTQUEUED)
105 N M,N,X W !
106 I '$D(ARRAY) W !,"No Authorized or Denied Days on file for this Visit!",!! Q
107 ;
108 W !,"For Insurance Company ",$P($G(^DIC(36,+IBCNS,0)),"^"),": "
109 I $G(ARRAY) W !,"Care Authorized for entire Admission on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY,0))),"."
110 I $G(ARRAY(0)) W !,"Care Denied for entire Admission on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(0),0))),"."
111 ;
112 S M=0 F S M=$O(ARRAY(M)) Q:'M S N="" F S N=$O(ARRAY(M,N)) Q:N="" D
113 .W !,"Care ",$S($P(ARRAY(M,N),"^",2)=1:"Authorized",1:"Denied ")," from ",$$FMTE^XLFDT(M)," to ",$S('N:"Unspecified",1:$$FMTE^XLFDT(N))
114 .W ?57," on ",$$FMTE^XLFDT(+$G(^IBT(356.2,+ARRAY(M,N),0))),"."
115 W ! Q
Note: See TracBrowser for help on using the repository browser.