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

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

initial load of WorldVistAEHR
File size: 3.7 KB
RevLine 
[613]1IBJTU3 ;ALB/ARH - TPI UTILITIES - INS ADDRESS ; 2/14/95
2 ;;2.0;INTEGRATED BILLING;**39,80**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5BADD(IBIFN) ; returns mailing address for bill
6 ; returns: COMPANY NAME ^ PHONE NUMBER ^ STR 1 ^ STR 2 ^ STR 3 ^ CITY ^ STATE ^ ZIP ^ ^ FAX #
7 N DFN,IBX,IBCNS,IBCDFN,IBTYP
8 ;
9 S IBX="",DFN=$G(^DGCR(399,+$G(IBIFN),0))
10 S IBTYP=$P(DFN,U,5),DFN=+$P(DFN,U,2) I 'DFN G BADDQ
11 S IBCNS=$G(^DGCR(399,+IBIFN,"MP")) I 'IBCNS G BADDQ
12 S IBCDFN=$P(IBCNS,U,2) I +IBCDFN S IBCNS=+$G(^DPT(DFN,.312,+IBCDFN,0))
13 ;
14 ; -- if send to employer and state defined, return employer address
15 I +IBCDFN S IBCDFN=$G(^DPT(DFN,.312,+IBCDFN,2)) I +IBCDFN,+$P(IBCDFN,U,6) D G BADDQ
16 . S IBX=$P(IBCDFN,U,9)_U_$P(IBCDFN,U,8)_U_$P(IBCDFN,U,2,7)
17 ;
18 S IBTYP=$S(IBTYP<3:"INP",1:"OPT")
19 S IBX=$$INSADD(+IBCNS,IBTYP)
20 ;
21BADDQ Q IBX
22 ;
23 ;
24INSADD(IBCNS,IBATYP) ; returns specific type of address/phone # for an insurance company, follows ptrs to company responsible
25 ; returns: COMPANY NAME ^ PHONE NUMBER ^ STR 1 ^ STR 2 ^ STR 3 ^ CITY ^ STATE ^ ZIP ^ ^ FAX #
26 ; if type does not have an address or phone number then main mailing addr/ph # is returned
27 ;
28 N IBD0,IBD13,IBADD,IBNM,IBPH,IBDN,IBCNT,IBAGAIN
29 S (IBADD,IBNM,IBPH)=""
30 ;
31MAIN ; -- determine address for company for type bill
32 ;
33 S IBD0=$G(^DIC(36,+$G(IBCNS),0)) I IBD0="" G MAINQ
34 S IBD13=$G(^DIC(36,IBCNS,.13))
35 ;
36 ; -- get name, main address, phone number
37 S IBNM=$P(IBD0,U,1),IBPH=$P(IBD13,U,1),IBADD=$G(^DIC(36,+IBCNS,.11))
38 ;
39 ; -- if process the same co. more than once you are in an infinate loop
40 I $D(IBCNT(IBCNS)) G MAINQ ;already processed this company use main add
41 S IBCNT(IBCNS)=""
42 ;
43 ; -- type of bill
44 I $G(IBATYP)'="",$T(@IBATYP)'="" D @IBATYP I $D(IBAGAIN) K IBAGAIN G MAIN
45 ;
46 ; -- return address
47MAINQ S IBNM=IBNM_U_IBPH_U_IBADD
48 Q IBNM
49 ;
50VER ; -- verification phone number
51 I $P(IBD13,U,4)'="" S IBPH=$P(IBD13,U,4)
52 Q
53 ;
54BILL ; -- billing phone number
55 I $P(IBD13,U,2)'="" S IBPH=$P(IBD13,U,2)
56 Q
57 ;
58PCERT ; -- precertification phone number
59 I $P(IBD13,U,3)'="" S IBPH=$P(IBD13,U,3)
60 ;
61 ; -- if other company processes precerts start again
62 I $P(IBD13,"^",9) S IBCNS=$P(IBD13,"^",9) S IBAGAIN=1
63 Q
64 ;
65INP ; -- inpatient phone number
66 I $P(IBD13,U,5)'="" S IBPH=$P(IBD13,U,5)
67 ;
68 ; -- see if there is an inpatient address, use if state is there
69 S IBDN=$G(^DIC(36,+IBCNS,.12)) I $P(IBDN,"^",5) S IBADD=IBDN
70 ;
71 ; -- if other company processes claims start again
72 I $P(IBDN,"^",7) S IBCNS=$P(IBDN,"^",7) S IBAGAIN=1
73 Q
74 ;
75OPT ; -- outpatient phone number
76 I $P(IBD13,U,6)'="" S IBPH=$P(IBD13,U,6)
77 ;
78 ; -- see if there is an outpatient address, use if state is there
79 S IBDN=$G(^DIC(36,+IBCNS,.16)) I $P(IBDN,"^",5) S IBADD=IBDN
80 ;
81 ; -- if other company processes claims start again
82 I $P(IBDN,"^",7) S IBCNS=$P(IBDN,"^",7) S IBAGAIN=1
83 Q
84 ;
85RX ; -- prescription phone number
86 I $P(IBD13,U,11)'="" S IBPH=$P(IBD13,U,11)
87 ;
88 ; -- see if there is an prescription address, use if state is there
89 S IBDN=$G(^DIC(36,+IBCNS,.18)) I $P(IBDN,"^",5) S IBADD=IBDN
90 ;
91 ; -- if other company processes claims start again
92 I $P(IBDN,"^",7) S IBCNS=$P(IBDN,"^",7) S IBAGAIN=1
93 Q
94 ;
95APL ; -- appeals phone number
96 I $P(IBD13,U,7)'="" S IBPH=$P(IBD13,U,7)
97 ;
98 ; -- see if there is an appeals address, use if state is there
99 S IBDN=$G(^DIC(36,+IBCNS,.14)) I $P(IBDN,"^",5) S IBADD=IBDN
100 ;
101 ; -- if other company processes claims start again
102 I $P(IBDN,"^",7) S IBCNS=$P(IBDN,"^",7) S IBAGAIN=1
103 Q
104 ;
105INQ ; -- inquiry phone number
106 I $P(IBD13,U,8)'="" S IBPH=$P(IBD13,U,8)
107 ;
108 ; -- see if there is an outpatient address, use if state is there
109 S IBDN=$G(^DIC(36,+IBCNS,.15)) I $P(IBDN,"^",5) S IBADD=IBDN
110 ;
111 ; -- if other company processes claims start again
112 I $P(IBDN,"^",7) S IBCNS=$P(IBDN,"^",7) S IBAGAIN=1
113 Q
Note: See TracBrowser for help on using the repository browser.