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,438,441**;Mar 20, 1995;Build 2
;;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,"")
I '$D(^XUSEC("PRCA MED DEBTOR EDIT",DUZ)) D Q ; PRCA*4.5*438
.W !,"Unable to edit this debtor's AR Debtor Address."
.W !,"A Medical Debtor's address is locked by the PRCA MED DEBTOR EDIT security key."
.W !,"Please contact Enrollment to have the Debtor's Confidential Address updated.",!
.Q
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
W !!,"You are not authorized to edit Institution file",!! ; PRCA*4.5*441
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 5687 printed Dec 13, 2024@01:42:24 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,438,441**;Mar 20, 1995;Build 2
+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,"")
+10 ; PRCA*4.5*438
IF '$DATA(^XUSEC("PRCA MED DEBTOR EDIT",DUZ))
Begin DoDot:1
+11 WRITE !,"Unable to edit this debtor's AR Debtor Address."
+12 WRITE !,"A Medical Debtor's address is locked by the PRCA MED DEBTOR EDIT security key."
+13 WRITE !,"Please contact Enrollment to have the Debtor's Confidential Address updated.",!
+14 QUIT
End DoDot:1
QUIT
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 ; PRCA*4.5*441
WRITE !!,"You are not authorized to edit Institution file",!!
+2 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
