RCAM ;WASH-ISC@ALTOONA,PA/RGY-Manager Debtor Information ;12/19/96 12:48 PM
V ;;4.5;Accounts Receivable;**34,190,198,223,359**;Mar 20, 1995;Build 13
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*359 Ensure displayed phone is correct format: 111-222-3333
;
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 ;
I $L($P(X,U,6))>5 S $P(X,U,6)=$E($P(X,U,6),1,5)_"-"_$E($P(X,U,6),6,9) ;PRCA*4.5*359
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
. I $L($P(ADR1,U,6))>5,$P(ADR1,U,6)'["-" S $P(ADR1,U,6)=$E($P(ADR1,U,6),1,5)_"-"_$E($P(ADR1,U,6),6,9) ;PRCA*4.5*359
. 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)
I $P(ADR1,U,7)?10N D ;PRCA*4.5*359
. N RCPHN
. S RCPHN=$P(ADR1,U,7),RCPHN=$E(RCPHN,1,3)_"-"_$E(RCPHN,4,6)_"-"_$E(RCPHN,7,10)
. S $P(ADR1,U,7)=RCPHN
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCAM 5380 printed Jun 11, 2024@21:32:25 Page 2
RCAM ;WASH-ISC@ALTOONA,PA/RGY-Manager Debtor Information ;12/19/96 12:48 PM
V ;;4.5;Accounts Receivable;**34,190,198,223,359**;Mar 20, 1995;Build 13
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*359 Ensure displayed phone is correct format: 111-222-3333
+4 ;
+5 NEW DIC,DIE,DIR,DIRUT,DUOUT,DTOUT,DR,DA,Y
+6 FOR
WRITE !
SET DIC="^RCD(340,"
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
QUIT
SET DA=+Y
SET DR=$SELECT($PIECE(Y,U,2)["DPT(":".02;",$PIECE(Y,U,2)[";DIC(36,":".05;",$PIECE(Y,U,2)[";DIC(4,":".05;",1:"")_2
SET DIE="^RCD(340,"
DO ^DIE
+7 QUIT
EDT ;Select AR Debtor address information
+1 NEW DIC,Y,RCDB
+2 NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+3 FOR
WRITE !
SET DIC="^RCD(340,"
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
QUIT
DO EN1($PIECE(^RCD(340,+Y,0),U))
if $DATA(DTOUT)
QUIT
+4 QUIT
EN1(RCDB) ;Edit Debtor address
+1 DO DIS(RCDB)
+2 IF RCDB["VA(200"
DO PER(RCDB)
GOTO Q2
+3 IF RCDB["DPT("
DO PAT(RCDB)
GOTO Q2
+4 IF RCDB["PRC(440"
DO VEN(RCDB)
GOTO Q2
+5 IF RCDB["DIC(4"
DO INST(RCDB)
GOTO Q2
+6 IF RCDB["DIC(36"
DO INSUR(RCDB)
Q2 QUIT
PER(RCDB) ;Edit person address
+1 NEW DA,DIE,DR
+2 SET DA=+RCDB
SET DIE="^VA(200,"
SET DR=".111;.112;.113;.114;.115;.116;.131"
DO ^DIE
+3 QUIT
INSUR(RCDB) ;Edit insurance address
+1 WRITE !!,"Sorry, edit to the insurance file must be done via MAS",!!
+2 QUIT
PAT(RCDB) ;Edit Patient Address
+1 NEW RCDB0,RCAD,DIR,DIRUT,DUOUT,DIROUT,DA,DIE,DR,ADR1,ADR2,ADR3
+2 SET RCDB0=$ORDER(^RCD(340,"B",RCDB,0))
+3 ;permanent address
SET ADR1=$$PAT^RCAMADD(+RCDB,0)
+4 ;confidential mailing address
SET ADR2=$$PAT^RCAMADD(+RCDB,1)
+5 ;accounts receivable address
SET ADR3=$$ARDEB^RCAMADD(RCDB0)
+6 WRITE !,"Address from Patient file: "
IF ADR2'=""
WRITE ?40,"Confidential Address from Patient file:"
+7 WRITE !
DO DIS2(ADR1,ADR2)
+8 WRITE !,"Address from AR Debtor file: "
+9 WRITE !
DO DIS2(ADR3,"")
PAT1 SET DA=RCDB0
+1 SET DIR("B")=$SELECT($PIECE($GET(^RCD(340,+RCDB0,1)),U,9):"YES",1:"NO")
+2 SET DIR(0)="340,1.09^AO"
DO ^DIR
+3 if $DATA(DIRUT)
GOTO Q1
+4 SET $PIECE(^RCD(340,+RCDB0,1),U,9)=Y
+5 SET DIE="^RCD(340,"
SET DR="[RCAM ADDRESS EDIT]"
DO ^DIE
+6 IF $PIECE($GET(^RCD(340,+RCDB0,1)),U,9)
Begin DoDot:1
+7 NEW DIK,DA,DR
+8 SET DA=$ORDER(^RC(341,"AD",+RCDB0,2,0))
+9 if 'DA
QUIT
SET DA=$ORDER(^RC(341,"AD",+RCDB0,2,DA,0))
+10 if 'DA
QUIT
+11 if '$PIECE($GET(^RC(341,+DA,0)),U,7)
QUIT
+12 SET RCDA=DA
+13 SET X1=DT
SET X2=$PIECE($GET(^RC(341,+DA,0)),U,7)
DO ^%DTC
+14 if X>90
QUIT
+15 SET DA=RCDA
+16 SET DIK="^RC(341,"
+17 DO ^DIK
+18 SET DA=""
FOR
SET DA=$ORDER(^PRCA(430,"AS",+RCDB0,16,DA))
if 'DA
QUIT
IF $GET(^PRCA(430,+DA,6))
SET $PIECE(^PRCA(430,+DA,6),U,7)=""
FOR DA(1)=1:1:3
SET $PIECE(^PRCA(430,+DA,6),U,DA(1))=""
End DoDot:1
CHK ;Check Address for patients
+1 SET Y=0
SET RCAD=$GET(^RCD(340,RCDB0,1))
FOR X=1,4,5,6
IF $PIECE(RCAD,U,X)]""
SET Y=Y+1
+2 IF $PIECE(RCAD,U,8)]""
SET Y=Y+1
+3 IF Y=4!'Y
GOTO Q1
+4 IF $PIECE(RCAD,U)]""
IF $PIECE(RCAD,U,4)]""
IF $PIECE(RCAD,U,5)]""
IF $PIECE(RCAD,U,6)]""
GOTO Q1
+5 IF $PIECE(RCAD,U)]""
IF $PIECE(RCAD,U,4)]""
IF $PIECE(RCAD,U,5)]""
IF $PIECE(RCAD,U,8)]""
GOTO Q1
+6 WRITE !!,"*** WARNING: There appears to be incomplete address information",!
+7 IF $DATA(DTOUT)
DO DELA
SET DTOUT=1
GOTO Q1
+8 WRITE !
SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="Do you want to re-edit the information? "
DO ^DIR
+9 if Y
GOTO PAT1
DO DELA
Q1 QUIT
DELA ;Delete AR debtor address information
+1 SET DA=RCDB0
SET DIE="^RCD(340,"
SET DR="1.01///@;1.02///@;1.03///@;1.04///@;1.05///@;1.06///@"
DO ^DIE
WRITE !,"*** Old address information deleted from AR address file ***",!
+2 QUIT
INST(RCDB) ;Edit institution
+1 NEW DA,DIE,DR
+2 SET DA=+RCDB
SET DIE="^DIC(4,"
SET DR="1.01;1.02;1.03;.02;1.04"
DO ^DIE
+3 QUIT
VEN(RCDB) ;Edit Vendor file
+1 NEW DA,DIE,DR
+2 SET DA=+RCDB
SET DIE="^PRC(440,"
SET DR="22.1;22.2;22.3;22.4;22.5;22.6;22.7"
DO ^DIE
+3 QUIT
DIS(RCDB) ;Display address information
+1 NEW RCDB0,RCCONF,ADR1,ADR2,RCNAM
+2 SET RCDB0=$ORDER(^RCD(340,"B",RCDB,0))
+3 if '$DATA(^RCD(340,+RCDB0,0))
GOTO Q3
+4 ;debtor name
SET RCNAM=$$NAM^RCFN01(RCDB0)
+5 SET ADR1=$$DADD^RCAMADD(RCDB)
SET ADR2=""
+6 ;get veteran's confidential address, if any
IF RCDB["DPT("
SET ADR2=$$PAT^RCAMADD(+RCDB,1)
+7 WRITE @IOF,!,"Address Accounts Receivable will use: "
+8 IF ADR2'=""
WRITE ?40,"Address for mailing to veteran:"
+9 WRITE !!
+10 WRITE ?3,RCNAM
IF ADR2'=""
WRITE ?42,RCNAM
+11 DO DIS2(ADR1,ADR2)
+12 IF $PIECE($GET(^RCD(340,RCDB0,0)),U,7)=1
Begin DoDot:1
+13 WRITE ?3,"Large print needed on statements: YES",!
End DoDot:1
Q3 QUIT
DIS1 ;
+1 ;PRCA*4.5*359
IF $LENGTH($PIECE(X,U,6))>5
SET $PIECE(X,U,6)=$EXTRACT($PIECE(X,U,6),1,5)_"-"_$EXTRACT($PIECE(X,U,6),6,9)
+2 WRITE !?5,$PIECE(X,U)
if $PIECE(X,U,2)]""
WRITE !?5,$PIECE(X,U,2)
if $PIECE(X,U,3)]""
WRITE !?5,$PIECE(X,U,3)
if $PIECE(X,U,4)]""
WRITE !?5,$PIECE(X,U,4),", ",$PIECE(X,U,5)," ",$PIECE(X,U,6)
if $PIECE(X,U,7)'=""
WRITE !?5,"Phone: ",$PIECE(X,U,7)
WRITE !
+3 QUIT
+4 ; Display two addresses in two columns.
DIS2(ADR1,ADR2) NEW TAB1,TAB2
+1 SET TAB1=3
SET TAB2=42
+2 IF ($PIECE(ADR1,U,1)'="")!($PIECE(ADR2,U,1)'="")
WRITE !?TAB1,$PIECE(ADR1,U,1)
IF $PIECE(ADR2,U,1)'=""
WRITE " ",?TAB2,$PIECE(ADR2,U,1)
+3 IF ($PIECE(ADR1,U,2)'="")!($PIECE(ADR2,U,2)'="")
WRITE !?TAB1,$PIECE(ADR1,U,2)
IF $PIECE(ADR2,U,2)'=""
WRITE " ",?TAB2,$PIECE(ADR2,U,2)
+4 IF ($PIECE(ADR1,U,3)'="")!($PIECE(ADR2,U,3)'="")
WRITE !?TAB1,$PIECE(ADR1,U,3)
IF $PIECE(ADR2,U,3)'=""
WRITE " ",?TAB2,$PIECE(ADR2,U,3)
+5 IF ($PIECE(ADR1,U,4)'="")!($PIECE(ADR2,U,4)'="")
WRITE !
Begin DoDot:1
+6 ;PRCA*4.5*359
IF $LENGTH($PIECE(ADR1,U,6))>5
IF $PIECE(ADR1,U,6)'["-"
SET $PIECE(ADR1,U,6)=$EXTRACT($PIECE(ADR1,U,6),1,5)_"-"_$EXTRACT($PIECE(ADR1,U,6),6,9)
+7 if $PIECE(ADR1,U,4)'=""
WRITE ?TAB1,$PIECE(ADR1,U,4),", ",$PIECE(ADR1,U,5)," ",$PIECE(ADR1,U,6)
+8 if $PIECE(ADR2,U,4)'=""
WRITE " ",?TAB2,$PIECE(ADR2,U,4),", ",$PIECE(ADR2,U,5)," ",$PIECE(ADR2,U,6)
End DoDot:1
+9 ;PRCA*4.5*359
IF $PIECE(ADR1,U,7)?10N
Begin DoDot:1
+10 NEW RCPHN
+11 SET RCPHN=$PIECE(ADR1,U,7)
SET RCPHN=$EXTRACT(RCPHN,1,3)_"-"_$EXTRACT(RCPHN,4,6)_"-"_$EXTRACT(RCPHN,7,10)
+12 SET $PIECE(ADR1,U,7)=RCPHN
End DoDot:1
+13 ; conf address doesn't have phone no.
if $PIECE(ADR1,U,7)'=""
WRITE !?TAB1,"Phone: ",$PIECE(ADR1,U,7)
+14 WRITE !
+15 QUIT
FOL ;Called by input transform from 341,4.02
+1 IF X<$PIECE($GET(^RC(341,DA,0)),U,6)
WRITE !!,*7,"Follow-up Date is before Date of Contact",!
KILL X
QUIT
+2 IF $PIECE($GET(^RC(341,DA,0)),U,6)=""
WRITE !!,*7,"Date of Contact does not exist!",!
KILL X
QUIT
+3 QUIT
