RCAMADD ;WASH-ISC@ALTOONA,PA/RGY - Get debtor address ;10/8/96 5:15 PM
V ;;4.5;Accounts Receivable;**34,190,336**;Mar 20, 1995;Build 45
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*336 Ensure the correct address is returned when
; no address node 1 is defined in file 340
; Also, ensure that the phone number defaults
; to 10 spaces if non-numeric.
;
;Get AR Debtor Address
; Input:
; RCDB - Pointer to AR DEBTOR file #340
; RCCONF (optional) - Confidential Address required, if applicable. 1-yes, 0(default)-no.
; Returns Debtor Address:
; Str1^Str2^Str3^City^State^ZIP^Telephone^Forein Country Code
DADD(RCDB,RCCONF,RCCSW) ;
N X
S X="" G:$G(RCDB)="" Q
I RCDB?1N.N S RCDB=$P($G(^RCD(340,RCDB,0)),"^")
; the confidential address has greatest priority for mailing
I $G(RCCONF),RCDB["DPT(" S X=$$PAT(+RCDB,1) I X'="" G Q
; the AR DEBTOR address (if exists) has a greater priority the permanent address in PATIENT file.
I RCDB["DPT(" S X=$$ARDEB(+$O(^RCD(340,"B",RCDB,0))) I ($P(X,U)'=""),($P(X,U,4)'=""),($P(X,U,5)'=""),(($P(X,U,6)'="")!($P(X,U,8)'="")) G Q
I RCDB["DPT(" S:'$G(RCCSW) X=$$PAT(+RCDB,0) S:$G(RCCSW) X=$$PAT1(+RCDB,0) G Q ;PRCA*4.5*336
I RCDB["DIC(4" S X=$$INST(+RCDB) G Q
I RCDB["PRC(440," S X=$$VEN(+RCDB) G Q
I RCDB["DIC(36," S X=$$INSUR(+RCDB) G Q
I RCDB["VA(200," S X=$$PER(+RCDB)
Q Q X
PER(RCDB) ;Get person address
N X,Y
S X="" G:'$D(^VA(200,+$G(RCDB),0)) Q1
S Y=$S($D(^VA(200,RCDB,.11)):^(.11),1:"") F I=1:1:6 S $P(X,"^",I)=$P(Y,"^",I)
S:$D(^VA(200,RCDB,.13)) $P(X,"^",7)=$P(^(.13),"^")
S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
Q1 Q X
INST(RCDB) ;Get institution address
N X,Y
S X="" G:'$D(^DIC(4,+$G(RCDB),0)) Q2
S $P(X,"^",5)=$P(^DIC(4,RCDB,0),"^",2),Y=$S($D(^DIC(4,RCDB,1)):^(1),1:""),$P(X,"^")=$P(Y,"^"),$P(X,"^",2)=$P(Y,"^",2),$P(X,"^",4)=$P(Y,"^",3),$P(X,"^",6)=$P(Y,"^",4)
S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
Q2 Q X
;
PAT(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT
; if RCCONF=0 (default), then return patients permanent address
; if RCCONF=1, then return confidential address, or NULL
N DFN,VAERR,VAPA,RCX,RCY,X,RCXX,RCYY,RCII
I '$D(^DPT(+$G(RCDB),0)) S RCX="" G Q3
S RCCONF=+$G(RCCONF) ; confidential address flag
S DFN=RCDB D ADD^VADPT
S RCX=""
;
I 'RCCONF D
. F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY)
. S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)
. S $P(RCX,"^",6)=$P($G(VAPA(11)),"^")
;
; is the confidential address available? Return NULL if not.
I RCCONF S RCX="" G:'$G(VAPA(12)) Q3 G:($P($G(VAPA(22,3)),U,3)'="Y") Q3 D
. F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY+12)
. S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(17),"^"),0)),"^",2)
. S $P(RCX,"^",6)=$P($G(VAPA(18)),"^")
S (RCXX,RCYY)=VAPA(8) ;PRCA*4.5*336
I RCXX'?10N D ;PRCA*4.5*336
. S RCYY="" F RCII=1:1:$L(RCXX) I $E(RCXX,RCII)?1N S RCYY=RCYY_$E(RCXX,RCII) ;PRCA*4.5*336
S VAPA(8)=$E("000000000000",1,10-$L(RCYY))_RCYY ;PRCA*4.5*336
S VAPA(8)=$S($L(RCYY)=10:RCYY,1:" ") ;PRCA*4.5*336
S $P(RCX,"^",7)=VAPA(8) ; Telephone ;PRCA*4.5*336
Q3 Q RCX
PAT1(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT ;PRCA*4.5*336
; if RCCONF=0 (default), then return patients permanent address
; if RCCONF=1, then return confidential address, or NULL
N DFN,RCX,RCY,RCII,RCTRY,RCYY,RCXX,VAPA,TELPHN
I '$D(^DPT(+$G(RCDB),0)) S RCX="" G Q3A
S DFN=RCDB D ADD^VADPT
S RCX=""
I 'RCCONF D
. F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY)
. S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(5),"^"),0)),"^",2)
. S $P(RCX,"^",6)=$P($G(VAPA(11)),"^"),TELPHN=VAPA(8)
;
; is the confidential address available? Return NULL if not.
I RCCONF S RCX="" G:'$G(VAPA(12))!($P($G(VAPA(22,3)),U,3)'="Y") Q3A D
. F RCY=1,2,3,4 S $P(RCX,"^",RCY)=VAPA(RCY+12)
. S $P(RCX,"^",5)=$P($G(^DIC(5,+$P(VAPA(17),"^"),0)),"^",2)
. S $P(RCX,"^",6)=$P($G(VAPA(18)),"^"),TELPHN=VAPA(8)
S RCYY="",RCXX=TELPHN F RCII=1:1:$L(RCXX) I $E(RCXX,RCII)?1N S RCYY=RCYY_$E(RCXX,RCII)
S VAPA(8)=$S($L(RCYY)=10:RCYY,1:" ") ;PRCA*4.5*336
S $P(RCX,U,7)=VAPA(8)
S $P(RCX,U,9)=0
I +VAPA(25)<3 S $P(RCX,U,8)="" G Q3A
S $P(RCX,U,4)=$E(VAPA(4)_" "_$E(VAPA(23),1,2)_" "_VAPA(24),1,25)
S $P(RCX,U,8)=+VAPA(25)
Q3A Q RCX
VEN(RCDB) ;Get vendor address
NEW X,Y,I
S X="" G:'$D(^PRC(440,+$G(RCDB),0)) Q4
S Y=$S($D(^PRC(440,RCDB,.11)):^(.11),1:"") F I=1:1:7 S $P(X,"^",I)=$P(Y,"^",I)
S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
Q4 Q X
INSUR(RCDB) ;Get insurance company address
NEW X,Y,I
S X="" G:'$D(^DIC(36,+$G(RCDB),0)) Q5
S Y=$S($D(^DIC(36,RCDB,.11)):^(.11),1:"") F I=1:1:6 S $P(X,"^",I)=$P(Y,"^",I)
S:$D(^DIC(36,RCDB,.13)) $P(X,"^",7)=$P(^(.13),"^",2)
S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
Q5 Q X
ARDEB(RCDB) ;Get address from AR Debtor file (340)
NEW X,Y,RCXX,RCYY
S X="" G:'$D(^RCD(340,+$G(RCDB),0)) Q6 S X=$P($G(^RCD(340,RCDB,1)),"^",1,8)
S $P(X,"^",5)=$P($G(^DIC(5,+$P(X,"^",5),0)),"^",2)
S RCYY="",RCXX=$P(X,"^",7) F RCII=1:1:$L(RCXX) I $E(RCXX,RCII)?1N S RCYY=RCYY_$E(RCXX,RCII)
S $P(X,"^",7)=$S($L(RCYY)=10:RCYY,1:" ")
Q6 Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCAMADD 5335 printed Oct 16, 2024@17:43:16 Page 2
RCAMADD ;WASH-ISC@ALTOONA,PA/RGY - Get debtor address ;10/8/96 5:15 PM
V ;;4.5;Accounts Receivable;**34,190,336**;Mar 20, 1995;Build 45
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*336 Ensure the correct address is returned when
+4 ; no address node 1 is defined in file 340
+5 ; Also, ensure that the phone number defaults
+6 ; to 10 spaces if non-numeric.
+7 ;
+8 ;Get AR Debtor Address
+9 ; Input:
+10 ; RCDB - Pointer to AR DEBTOR file #340
+11 ; RCCONF (optional) - Confidential Address required, if applicable. 1-yes, 0(default)-no.
+12 ; Returns Debtor Address:
+13 ; Str1^Str2^Str3^City^State^ZIP^Telephone^Forein Country Code
DADD(RCDB,RCCONF,RCCSW) ;
+1 NEW X
+2 SET X=""
if $GET(RCDB)=""
GOTO Q
+3 IF RCDB?1N.N
SET RCDB=$PIECE($GET(^RCD(340,RCDB,0)),"^")
+4 ; the confidential address has greatest priority for mailing
+5 IF $GET(RCCONF)
IF RCDB["DPT("
SET X=$$PAT(+RCDB,1)
IF X'=""
GOTO Q
+6 ; the AR DEBTOR address (if exists) has a greater priority the permanent address in PATIENT file.
+7 IF RCDB["DPT("
SET X=$$ARDEB(+$ORDER(^RCD(340,"B",RCDB,0)))
IF ($PIECE(X,U)'="")
IF ($PIECE(X,U,4)'="")
IF ($PIECE(X,U,5)'="")
IF (($PIECE(X,U,6)'="")!($PIECE(X,U,8)'=""))
GOTO Q
+8 ;PRCA*4.5*336
IF RCDB["DPT("
if '$GET(RCCSW)
SET X=$$PAT(+RCDB,0)
if $GET(RCCSW)
SET X=$$PAT1(+RCDB,0)
GOTO Q
+9 IF RCDB["DIC(4"
SET X=$$INST(+RCDB)
GOTO Q
+10 IF RCDB["PRC(440,"
SET X=$$VEN(+RCDB)
GOTO Q
+11 IF RCDB["DIC(36,"
SET X=$$INSUR(+RCDB)
GOTO Q
+12 IF RCDB["VA(200,"
SET X=$$PER(+RCDB)
Q QUIT X
PER(RCDB) ;Get person address
+1 NEW X,Y
+2 SET X=""
if '$DATA(^VA(200,+$GET(RCDB),0))
GOTO Q1
+3 SET Y=$SELECT($DATA(^VA(200,RCDB,.11)):^(.11),1:"")
FOR I=1:1:6
SET $PIECE(X,"^",I)=$PIECE(Y,"^",I)
+4 if $DATA(^VA(200,RCDB,.13))
SET $PIECE(X,"^",7)=$PIECE(^(.13),"^")
+5 SET $PIECE(X,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^",2)
Q1 QUIT X
INST(RCDB) ;Get institution address
+1 NEW X,Y
+2 SET X=""
if '$DATA(^DIC(4,+$GET(RCDB),0))
GOTO Q2
+3 SET $PIECE(X,"^",5)=$PIECE(^DIC(4,RCDB,0),"^",2)
SET Y=$SELECT($DATA(^DIC(4,RCDB,1)):^(1),1:"")
SET $PIECE(X,"^")=$PIECE(Y,"^")
SET $PIECE(X,"^",2)=$PIECE(Y,"^",2)
SET $PIECE(X,"^",4)=$PIECE(Y,"^",3)
SET $PIECE(X,"^",6)=$PIECE(Y,"^",4)
+4 SET $PIECE(X,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^",2)
Q2 QUIT X
+1 ;
PAT(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT
+1 ; if RCCONF=0 (default), then return patients permanent address
+2 ; if RCCONF=1, then return confidential address, or NULL
+3 NEW DFN,VAERR,VAPA,RCX,RCY,X,RCXX,RCYY,RCII
+4 IF '$DATA(^DPT(+$GET(RCDB),0))
SET RCX=""
GOTO Q3
+5 ; confidential address flag
SET RCCONF=+$GET(RCCONF)
+6 SET DFN=RCDB
DO ADD^VADPT
+7 SET RCX=""
+8 ;
+9 IF 'RCCONF
Begin DoDot:1
+10 FOR RCY=1,2,3,4
SET $PIECE(RCX,"^",RCY)=VAPA(RCY)
+11 SET $PIECE(RCX,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(VAPA(5),"^"),0)),"^",2)
+12 SET $PIECE(RCX,"^",6)=$PIECE($GET(VAPA(11)),"^")
End DoDot:1
+13 ;
+14 ; is the confidential address available? Return NULL if not.
+15 IF RCCONF
SET RCX=""
if '$GET(VAPA(12))
GOTO Q3
if ($PIECE($GET(VAPA(22,3)),U,3)'="Y")
GOTO Q3
Begin DoDot:1
+16 FOR RCY=1,2,3,4
SET $PIECE(RCX,"^",RCY)=VAPA(RCY+12)
+17 SET $PIECE(RCX,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(VAPA(17),"^"),0)),"^",2)
+18 SET $PIECE(RCX,"^",6)=$PIECE($GET(VAPA(18)),"^")
End DoDot:1
+19 ;PRCA*4.5*336
SET (RCXX,RCYY)=VAPA(8)
+20 ;PRCA*4.5*336
IF RCXX'?10N
Begin DoDot:1
+21 ;PRCA*4.5*336
SET RCYY=""
FOR RCII=1:1:$LENGTH(RCXX)
IF $EXTRACT(RCXX,RCII)?1N
SET RCYY=RCYY_$EXTRACT(RCXX,RCII)
End DoDot:1
+22 ;PRCA*4.5*336
SET VAPA(8)=$EXTRACT("000000000000",1,10-$LENGTH(RCYY))_RCYY
+23 ;PRCA*4.5*336
SET VAPA(8)=$SELECT($LENGTH(RCYY)=10:RCYY,1:" ")
+24 ; Telephone ;PRCA*4.5*336
SET $PIECE(RCX,"^",7)=VAPA(8)
Q3 QUIT RCX
PAT1(RCDB,RCCONF) ;Get patient address as "Str1^Str2^Str3^City^State^ZIP^Telephone" from ^DPT ;PRCA*4.5*336
+1 ; if RCCONF=0 (default), then return patients permanent address
+2 ; if RCCONF=1, then return confidential address, or NULL
+3 NEW DFN,RCX,RCY,RCII,RCTRY,RCYY,RCXX,VAPA,TELPHN
+4 IF '$DATA(^DPT(+$GET(RCDB),0))
SET RCX=""
GOTO Q3A
+5 SET DFN=RCDB
DO ADD^VADPT
+6 SET RCX=""
+7 IF 'RCCONF
Begin DoDot:1
+8 FOR RCY=1,2,3,4
SET $PIECE(RCX,"^",RCY)=VAPA(RCY)
+9 SET $PIECE(RCX,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(VAPA(5),"^"),0)),"^",2)
+10 SET $PIECE(RCX,"^",6)=$PIECE($GET(VAPA(11)),"^")
SET TELPHN=VAPA(8)
End DoDot:1
+11 ;
+12 ; is the confidential address available? Return NULL if not.
+13 IF RCCONF
SET RCX=""
if '$GET(VAPA(12))!($PIECE($GET(VAPA(22,3)),U,3)'="Y")
GOTO Q3A
Begin DoDot:1
+14 FOR RCY=1,2,3,4
SET $PIECE(RCX,"^",RCY)=VAPA(RCY+12)
+15 SET $PIECE(RCX,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(VAPA(17),"^"),0)),"^",2)
+16 SET $PIECE(RCX,"^",6)=$PIECE($GET(VAPA(18)),"^")
SET TELPHN=VAPA(8)
End DoDot:1
+17 SET RCYY=""
SET RCXX=TELPHN
FOR RCII=1:1:$LENGTH(RCXX)
IF $EXTRACT(RCXX,RCII)?1N
SET RCYY=RCYY_$EXTRACT(RCXX,RCII)
+18 ;PRCA*4.5*336
SET VAPA(8)=$SELECT($LENGTH(RCYY)=10:RCYY,1:" ")
+19 SET $PIECE(RCX,U,7)=VAPA(8)
+20 SET $PIECE(RCX,U,9)=0
+21 IF +VAPA(25)<3
SET $PIECE(RCX,U,8)=""
GOTO Q3A
+22 SET $PIECE(RCX,U,4)=$EXTRACT(VAPA(4)_" "_$EXTRACT(VAPA(23),1,2)_" "_VAPA(24),1,25)
+23 SET $PIECE(RCX,U,8)=+VAPA(25)
Q3A QUIT RCX
VEN(RCDB) ;Get vendor address
+1 NEW X,Y,I
+2 SET X=""
if '$DATA(^PRC(440,+$GET(RCDB),0))
GOTO Q4
+3 SET Y=$SELECT($DATA(^PRC(440,RCDB,.11)):^(.11),1:"")
FOR I=1:1:7
SET $PIECE(X,"^",I)=$PIECE(Y,"^",I)
+4 SET $PIECE(X,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^",2)
Q4 QUIT X
INSUR(RCDB) ;Get insurance company address
+1 NEW X,Y,I
+2 SET X=""
if '$DATA(^DIC(36,+$GET(RCDB),0))
GOTO Q5
+3 SET Y=$SELECT($DATA(^DIC(36,RCDB,.11)):^(.11),1:"")
FOR I=1:1:6
SET $PIECE(X,"^",I)=$PIECE(Y,"^",I)
+4 if $DATA(^DIC(36,RCDB,.13))
SET $PIECE(X,"^",7)=$PIECE(^(.13),"^",2)
+5 SET $PIECE(X,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^",2)
Q5 QUIT X
ARDEB(RCDB) ;Get address from AR Debtor file (340)
+1 NEW X,Y,RCXX,RCYY
+2 SET X=""
if '$DATA(^RCD(340,+$GET(RCDB),0))
GOTO Q6
SET X=$PIECE($GET(^RCD(340,RCDB,1)),"^",1,8)
+3 SET $PIECE(X,"^",5)=$PIECE($GET(^DIC(5,+$PIECE(X,"^",5),0)),"^",2)
+4 SET RCYY=""
SET RCXX=$PIECE(X,"^",7)
FOR RCII=1:1:$LENGTH(RCXX)
IF $EXTRACT(RCXX,RCII)?1N
SET RCYY=RCYY_$EXTRACT(RCXX,RCII)
+5 SET $PIECE(X,"^",7)=$SELECT($LENGTH(RCYY)=10:RCYY,1:" ")
Q6 QUIT X
