112 lines
4.7 KiB
Mathematica
112 lines
4.7 KiB
Mathematica
RCAM ;WASH-ISC@ALTOONA,PA/RGY-Manager Debtor Information ;12/19/96 12:48 PM
|
|
V ;;4.5;Accounts Receivable;**34,190,198,223**;Mar 20, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
NEW DIC,DIE,DIR,DIRUT,DUOUT,DTOUT,DR,DA,Y
|
|
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
|
|
Q
|
|
EDT ;Select AR Debtor address information
|
|
NEW DIC,Y,RCDB
|
|
N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
|
|
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)
|
|
Q
|
|
EN1(RCDB) ;Edit Debtor address
|
|
D DIS(RCDB)
|
|
I RCDB["VA(200" D PER(RCDB) G Q2
|
|
I RCDB["DPT(" D PAT(RCDB) G Q2
|
|
I RCDB["PRC(440" D VEN(RCDB) G Q2
|
|
I RCDB["DIC(4" D INST(RCDB) G Q2
|
|
I RCDB["DIC(36" D INSUR(RCDB)
|
|
Q2 Q
|
|
PER(RCDB) ;Edit person address
|
|
NEW DA,DIE,DR
|
|
S DA=+RCDB,DIE="^VA(200,",DR=".111;.112;.113;.114;.115;.116;.131" D ^DIE
|
|
Q
|
|
INSUR(RCDB) ;Edit insurance address
|
|
W !!,"Sorry, edit to the insurance file must be done via MAS",!!
|
|
Q
|
|
PAT(RCDB) ;Edit Patient Address
|
|
NEW RCDB0,RCAD,DIR,DIRUT,DUOUT,DIROUT,DA,DIE,DR,ADR1,ADR2,ADR3
|
|
S RCDB0=$O(^RCD(340,"B",RCDB,0))
|
|
S ADR1=$$PAT^RCAMADD(+RCDB,0) ;permanent address
|
|
S ADR2=$$PAT^RCAMADD(+RCDB,1) ;confidential mailing address
|
|
S ADR3=$$ARDEB^RCAMADD(RCDB0) ;accounts receivable address
|
|
W !,"Address from Patient file: " I ADR2'="" W ?40,"Confidential Address from Patient file:"
|
|
W ! D DIS2(ADR1,ADR2)
|
|
W !,"Address from AR Debtor file: "
|
|
W ! D DIS2(ADR3,"")
|
|
PAT1 S DA=RCDB0
|
|
S DIR("B")=$S($P($G(^RCD(340,+RCDB0,1)),U,9):"YES",1:"NO")
|
|
S DIR(0)="340,1.09^AO" D ^DIR
|
|
G:$D(DIRUT) Q1
|
|
S $P(^RCD(340,+RCDB0,1),U,9)=Y
|
|
S DIE="^RCD(340,",DR="[RCAM ADDRESS EDIT]" D ^DIE
|
|
I $P($G(^RCD(340,+RCDB0,1)),U,9) D
|
|
.N DIK,DA,DR
|
|
.S DA=$O(^RC(341,"AD",+RCDB0,2,0))
|
|
.Q:'DA S DA=$O(^RC(341,"AD",+RCDB0,2,DA,0))
|
|
.Q:'DA
|
|
.Q:'$P($G(^RC(341,+DA,0)),U,7)
|
|
.S RCDA=DA
|
|
.S X1=DT,X2=$P($G(^RC(341,+DA,0)),U,7) D ^%DTC
|
|
.Q:X>90
|
|
.S DA=RCDA
|
|
.S DIK="^RC(341,"
|
|
.D ^DIK
|
|
.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))=""
|
|
CHK ;Check Address for patients
|
|
S Y=0,RCAD=$G(^RCD(340,RCDB0,1)) F X=1,4,5,6 I $P(RCAD,U,X)]"" S Y=Y+1
|
|
I $P(RCAD,U,8)]"" S Y=Y+1
|
|
I Y=4!'Y G Q1
|
|
I $P(RCAD,U)]"",$P(RCAD,U,4)]"",$P(RCAD,U,5)]"",$P(RCAD,U,6)]"" G Q1
|
|
I $P(RCAD,U)]"",$P(RCAD,U,4)]"",$P(RCAD,U,5)]"",$P(RCAD,U,8)]"" G Q1
|
|
W !!,"*** WARNING: There appears to be incomplete address information",!
|
|
I $D(DTOUT) D DELA S DTOUT=1 G Q1
|
|
W ! S DIR(0)="YA",DIR("B")="YES",DIR("A")="Do you want to re-edit the information? " D ^DIR
|
|
G:Y PAT1 D DELA
|
|
Q1 Q
|
|
DELA ;Delete AR debtor address information
|
|
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 ***",!
|
|
Q
|
|
INST(RCDB) ;Edit institution
|
|
NEW DA,DIE,DR
|
|
S DA=+RCDB,DIE="^DIC(4,",DR="1.01;1.02;1.03;.02;1.04" D ^DIE
|
|
Q
|
|
VEN(RCDB) ;Edit Vendor file
|
|
NEW DA,DIE,DR
|
|
S DA=+RCDB,DIE="^PRC(440,",DR="22.1;22.2;22.3;22.4;22.5;22.6;22.7" D ^DIE
|
|
Q
|
|
DIS(RCDB) ;Display address information
|
|
NEW RCDB0,RCCONF,ADR1,ADR2,RCNAM
|
|
S RCDB0=$O(^RCD(340,"B",RCDB,0))
|
|
G:'$D(^RCD(340,+RCDB0,0)) Q3
|
|
S RCNAM=$$NAM^RCFN01(RCDB0) ;debtor name
|
|
S ADR1=$$DADD^RCAMADD(RCDB),ADR2=""
|
|
I RCDB["DPT(" S ADR2=$$PAT^RCAMADD(+RCDB,1) ;get veteran's confidential address, if any
|
|
W @IOF,!,"Address Accounts Receivable will use: "
|
|
I ADR2'="" W ?40,"Address for mailing to veteran:"
|
|
W !!
|
|
W ?3,RCNAM I ADR2'="" W ?42,RCNAM
|
|
D DIS2(ADR1,ADR2)
|
|
I $P($G(^RCD(340,RCDB0,0)),U,7)=1 D
|
|
. W ?3,"Large print needed on statements: YES",!
|
|
Q3 Q
|
|
DIS1 ;
|
|
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 !
|
|
Q
|
|
; Display two addresses in two columns.
|
|
DIS2(ADR1,ADR2) N TAB1,TAB2
|
|
S TAB1=3,TAB2=42
|
|
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)
|
|
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)
|
|
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)
|
|
I ($P(ADR1,U,4)'="")!($P(ADR2,U,4)'="") W ! D
|
|
. W:$P(ADR1,U,4)'="" ?TAB1,$P(ADR1,U,4),", ",$P(ADR1,U,5)," ",$P(ADR1,U,6)
|
|
. W:$P(ADR2,U,4)'="" " ",?TAB2,$P(ADR2,U,4),", ",$P(ADR2,U,5)," ",$P(ADR2,U,6)
|
|
W:$P(ADR1,U,7)'="" !?TAB1,"Phone: ",$P(ADR1,U,7) ; conf address doesn't have phone no.
|
|
W !
|
|
Q
|
|
FOL ;Called by input transform from 341,4.02
|
|
I X<$P($G(^RC(341,DA,0)),U,6) W !!,*7,"Follow-up Date is before Date of Contact",! K X Q
|
|
I $P($G(^RC(341,DA,0)),U,6)="" W !!,*7,"Date of Contact does not exist!",! K X Q
|
|
Q
|