source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCAMADD.m@ 1261

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

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1RCAMADD ;WASH-ISC@ALTOONA,PA/RGY-Get debtor address ;10/8/96 5:15 PM
2V ;;4.5;Accounts Receivable;**34,190**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;Get AR Debtor Address
6 ; Input:
7 ; RCDB - Pointer to AR DEBTOR file #340
8 ; RCCONF (optional) - Confidential Address required, if applicable. 1-yes, 0(default)-no.
9 ; Returns Debtor Address:
10 ; Str1^Str2^Str3^City^State^ZIP^Telephone^Forein Country Code
11DADD(RCDB,RCCONF) ;
12 N X
13 S X="" G:$G(RCDB)="" Q
14 I RCDB?1N.N S RCDB=$P($G(^RCD(340,RCDB,0)),"^")
15 ; the confidential address has greatest priority for mailing
16 I $G(RCCONF),RCDB["DPT(" S X=$$PAT(+RCDB,1) I X'="" G Q
17 ; the AR DEBTOR address (if exists) has a greater priority the permanent address in PATIENT file.
18 I RCDB["DPT(" S X=$$ARDEB(+$O(^RCD(340,"B",RCDB,0))) I ($P(X,U)'=""),($P(X,U,4)'=""),($P(X,U,5)'=""),(($P(X,U,6)'="")!($P(X,U,8)'="")) G Q
19 I RCDB["DPT(" S X=$$PAT(+RCDB,0) G Q
20 I RCDB["DIC(4" S X=$$INST(+RCDB) G Q
21 I RCDB["PRC(440," S X=$$VEN(+RCDB) G Q
22 I RCDB["DIC(36," S X=$$INSUR(+RCDB) G Q
23 I RCDB["VA(200," S X=$$PER(+RCDB)
24Q Q X
25PER(RCDB) ;Get person address
26 N X,Y
27 S X="" G:'$D(^VA(200,+$G(RCDB),0)) Q1
28 S Y=$S($D(^VA(200,RCDB,.11)):^(.11),1:"") F I=1:1:6 S $P(X,"^",I)=$P(Y,"^",I)
29 S:$D(^VA(200,RCDB,.13)) $P(X,"^",7)=$P(^(.13),"^")
30 S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
31Q1 Q X
32INST(RCDB) ;Get institution address
33 N X,Y
34 S X="" G:'$D(^DIC(4,+$G(RCDB),0)) Q2
35 S $P(X,"^",5)=$P(^DIC(4,RCDB,0),"^",2),Y=$S($D(^DIC(4,RCDB,1)):^(1),1:""),$P(X,"^")=$P(Y,"^"),$P(X,"^",2)=$P(Y,"^",2),$P(X,"^",4)=$P(Y,"^",3),$P(X,"^",6)=$P(Y,"^",4)
36 S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
37Q2 Q X
38 ;
39PAT(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT
40 ; if RCCONF=0 (default), then return patients permanent address
41 ; if RCCONF=1, then return confidential address, or NULL
42 N DFN,VAERR,VAPA,RCX,RCY,X
43 I '$D(^DPT(+$G(RCDB),0)) S RCX="" G Q3
44 S RCCONF=+$G(RCCONF) ; confidential address flag
45 S DFN=RCDB D ADD^VADPT
46 S RCX=""
47 ;
48 I 'RCCONF D
49 . F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY)
50 . S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)
51 . S $P(RCX,"^",6)=$P($G(VAPA(11)),"^")
52 ;
53 ; is the confidential address available? Return NULL if not.
54 I RCCONF S RCX="" G:'$G(VAPA(12)) Q3 G:($P($G(VAPA(22,3)),U,3)'="Y") Q3 D
55 . F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY+12)
56 . S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(17),"^"),0)),"^",2)
57 . S $P(RCX,"^",6)=$P($G(VAPA(18)),"^")
58 S $P(RCX,"^",7)=VAPA(8) ; Telephone
59Q3 Q RCX
60VEN(RCDB) ;Get vendor address
61 NEW X,Y,I
62 S X="" G:'$D(^PRC(440,+$G(RCDB),0)) Q4
63 S Y=$S($D(^PRC(440,RCDB,.11)):^(.11),1:"") F I=1:1:7 S $P(X,"^",I)=$P(Y,"^",I)
64 S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
65Q4 Q X
66INSUR(RCDB) ;Get insurance company address
67 NEW X,Y,I
68 S X="" G:'$D(^DIC(36,+$G(RCDB),0)) Q5
69 S Y=$S($D(^DIC(36,RCDB,.11)):^(.11),1:"") F I=1:1:6 S $P(X,"^",I)=$P(Y,"^",I)
70 S:$D(^DIC(36,RCDB,.13)) $P(X,"^",7)=$P(^(.13),"^",2)
71 S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
72Q5 Q X
73ARDEB(RCDB) ;Get address from AR Debtor file (340)
74 NEW X,Y
75 S X="" G:'$D(^RCD(340,+$G(RCDB),0)) Q6 S X=$P($G(^RCD(340,RCDB,1)),"^",1,8)
76 S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
77Q6 Q X
Note: See TracBrowser for help on using the repository browser.