- 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 Feb 18, 2025@23:08:48 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