source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCAM.m@ 701

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1RCAM ;WASH-ISC@ALTOONA,PA/RGY-Manager Debtor Information ;12/19/96 12:48 PM
2V ;;4.5;Accounts Receivable;**34,190,198,223**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 NEW DIC,DIE,DIR,DIRUT,DUOUT,DTOUT,DR,DA,Y
5 F W ! S DIC="^RCD(340,",DIC(0)="QEAM" D ^DIC Q:Y<0 S DA=+Y,DR=$S($P(Y,U,2)["DPT(":".02;",$P(Y,U,2)[";DIC(36,":".05;",$P(Y,U,2)[";DIC(4,":".05;",1:"")_2,DIE="^RCD(340," D ^DIE
6 Q
7EDT ;Select AR Debtor address information
8 NEW DIC,Y,RCDB
9 N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
10 F W ! S DIC="^RCD(340,",DIC(0)="QEAM" D ^DIC Q:Y<0 D EN1($P(^RCD(340,+Y,0),U)) Q:$D(DTOUT)
11 Q
12EN1(RCDB) ;Edit Debtor address
13 D DIS(RCDB)
14 I RCDB["VA(200" D PER(RCDB) G Q2
15 I RCDB["DPT(" D PAT(RCDB) G Q2
16 I RCDB["PRC(440" D VEN(RCDB) G Q2
17 I RCDB["DIC(4" D INST(RCDB) G Q2
18 I RCDB["DIC(36" D INSUR(RCDB)
19Q2 Q
20PER(RCDB) ;Edit person address
21 NEW DA,DIE,DR
22 S DA=+RCDB,DIE="^VA(200,",DR=".111;.112;.113;.114;.115;.116;.131" D ^DIE
23 Q
24INSUR(RCDB) ;Edit insurance address
25 W !!,"Sorry, edit to the insurance file must be done via MAS",!!
26 Q
27PAT(RCDB) ;Edit Patient Address
28 NEW RCDB0,RCAD,DIR,DIRUT,DUOUT,DIROUT,DA,DIE,DR,ADR1,ADR2,ADR3
29 S RCDB0=$O(^RCD(340,"B",RCDB,0))
30 S ADR1=$$PAT^RCAMADD(+RCDB,0) ;permanent address
31 S ADR2=$$PAT^RCAMADD(+RCDB,1) ;confidential mailing address
32 S ADR3=$$ARDEB^RCAMADD(RCDB0) ;accounts receivable address
33 W !,"Address from Patient file: " I ADR2'="" W ?40,"Confidential Address from Patient file:"
34 W ! D DIS2(ADR1,ADR2)
35 W !,"Address from AR Debtor file: "
36 W ! D DIS2(ADR3,"")
37PAT1 S DA=RCDB0
38 S DIR("B")=$S($P($G(^RCD(340,+RCDB0,1)),U,9):"YES",1:"NO")
39 S DIR(0)="340,1.09^AO" D ^DIR
40 G:$D(DIRUT) Q1
41 S $P(^RCD(340,+RCDB0,1),U,9)=Y
42 S DIE="^RCD(340,",DR="[RCAM ADDRESS EDIT]" D ^DIE
43 I $P($G(^RCD(340,+RCDB0,1)),U,9) D
44 .N DIK,DA,DR
45 .S DA=$O(^RC(341,"AD",+RCDB0,2,0))
46 .Q:'DA S DA=$O(^RC(341,"AD",+RCDB0,2,DA,0))
47 .Q:'DA
48 .Q:'$P($G(^RC(341,+DA,0)),U,7)
49 .S RCDA=DA
50 .S X1=DT,X2=$P($G(^RC(341,+DA,0)),U,7) D ^%DTC
51 .Q:X>90
52 .S DA=RCDA
53 .S DIK="^RC(341,"
54 .D ^DIK
55 .S DA="" F S DA=$O(^PRCA(430,"AS",+RCDB0,16,DA)) Q:'DA I $G(^PRCA(430,+DA,6)) S $P(^PRCA(430,+DA,6),U,7)="" F DA(1)=1:1:3 S $P(^PRCA(430,+DA,6),U,DA(1))=""
56CHK ;Check Address for patients
57 S Y=0,RCAD=$G(^RCD(340,RCDB0,1)) F X=1,4,5,6 I $P(RCAD,U,X)]"" S Y=Y+1
58 I $P(RCAD,U,8)]"" S Y=Y+1
59 I Y=4!'Y G Q1
60 I $P(RCAD,U)]"",$P(RCAD,U,4)]"",$P(RCAD,U,5)]"",$P(RCAD,U,6)]"" G Q1
61 I $P(RCAD,U)]"",$P(RCAD,U,4)]"",$P(RCAD,U,5)]"",$P(RCAD,U,8)]"" G Q1
62 W !!,"*** WARNING: There appears to be incomplete address information",!
63 I $D(DTOUT) D DELA S DTOUT=1 G Q1
64 W ! S DIR(0)="YA",DIR("B")="YES",DIR("A")="Do you want to re-edit the information? " D ^DIR
65 G:Y PAT1 D DELA
66Q1 Q
67DELA ;Delete AR debtor address information
68 S DA=RCDB0,DIE="^RCD(340,",DR="1.01///@;1.02///@;1.03///@;1.04///@;1.05///@;1.06///@" D ^DIE W !,"*** Old address information deleted from AR address file ***",!
69 Q
70INST(RCDB) ;Edit institution
71 NEW DA,DIE,DR
72 S DA=+RCDB,DIE="^DIC(4,",DR="1.01;1.02;1.03;.02;1.04" D ^DIE
73 Q
74VEN(RCDB) ;Edit Vendor file
75 NEW DA,DIE,DR
76 S DA=+RCDB,DIE="^PRC(440,",DR="22.1;22.2;22.3;22.4;22.5;22.6;22.7" D ^DIE
77 Q
78DIS(RCDB) ;Display address information
79 NEW RCDB0,RCCONF,ADR1,ADR2,RCNAM
80 S RCDB0=$O(^RCD(340,"B",RCDB,0))
81 G:'$D(^RCD(340,+RCDB0,0)) Q3
82 S RCNAM=$$NAM^RCFN01(RCDB0) ;debtor name
83 S ADR1=$$DADD^RCAMADD(RCDB),ADR2=""
84 I RCDB["DPT(" S ADR2=$$PAT^RCAMADD(+RCDB,1) ;get veteran's confidential address, if any
85 W @IOF,!,"Address Accounts Receivable will use: "
86 I ADR2'="" W ?40,"Address for mailing to veteran:"
87 W !!
88 W ?3,RCNAM I ADR2'="" W ?42,RCNAM
89 D DIS2(ADR1,ADR2)
90 I $P($G(^RCD(340,RCDB0,0)),U,7)=1 D
91 . W ?3,"Large print needed on statements: YES",!
92Q3 Q
93DIS1 ;
94 W !?5,$P(X,U) W:$P(X,U,2)]"" !?5,$P(X,U,2) W:$P(X,U,3)]"" !?5,$P(X,U,3) W:$P(X,U,4)]"" !?5,$P(X,U,4),", ",$P(X,U,5)," ",$P(X,U,6) W:$P(X,U,7)'="" !?5,"Phone: ",$P(X,U,7) W !
95 Q
96 ; Display two addresses in two columns.
97DIS2(ADR1,ADR2) N TAB1,TAB2
98 S TAB1=3,TAB2=42
99 I ($P(ADR1,U,1)'="")!($P(ADR2,U,1)'="") W !?TAB1,$P(ADR1,U,1) I $P(ADR2,U,1)'="" W " ",?TAB2,$P(ADR2,U,1)
100 I ($P(ADR1,U,2)'="")!($P(ADR2,U,2)'="") W !?TAB1,$P(ADR1,U,2) I $P(ADR2,U,2)'="" W " ",?TAB2,$P(ADR2,U,2)
101 I ($P(ADR1,U,3)'="")!($P(ADR2,U,3)'="") W !?TAB1,$P(ADR1,U,3) I $P(ADR2,U,3)'="" W " ",?TAB2,$P(ADR2,U,3)
102 I ($P(ADR1,U,4)'="")!($P(ADR2,U,4)'="") W ! D
103 . W:$P(ADR1,U,4)'="" ?TAB1,$P(ADR1,U,4),", ",$P(ADR1,U,5)," ",$P(ADR1,U,6)
104 . W:$P(ADR2,U,4)'="" " ",?TAB2,$P(ADR2,U,4),", ",$P(ADR2,U,5)," ",$P(ADR2,U,6)
105 W:$P(ADR1,U,7)'="" !?TAB1,"Phone: ",$P(ADR1,U,7) ; conf address doesn't have phone no.
106 W !
107 Q
108FOL ;Called by input transform from 341,4.02
109 I X<$P($G(^RC(341,DA,0)),U,6) W !!,*7,"Follow-up Date is before Date of Contact",! K X Q
110 I $P($G(^RC(341,DA,0)),U,6)="" W !!,*7,"Date of Contact does not exist!",! K X Q
111 Q
Note: See TracBrowser for help on using the repository browser.