RCDPAPLM ;WISC/RFJ-account profile top list manager routine ;1 Jun 99
;;4.5;Accounts Receivable;**114**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
N RCDPFXIT
;
ACCTPROF ; this entry point called by link payment to prevent newing
; the fast exit variable RCDPFXIT
N RCDEBTDA
;
; check to see if user has any selected status's to display,
; if not, set up the default status's
I $G(^DISV(DUZ,"RCDPAPLM","STATUS"))="" D DEFAULT^RCDPAPST
;
F D Q:'RCDEBTDA
. W !! S RCDEBTDA=$$SELACCT
. I RCDEBTDA<1 S RCDEBTDA=0 Q
. D EN^VALM("RCDP ACCOUNT PROFILE")
. ; fast exit
. I $G(RCDPFXIT) S RCDEBTDA=0
Q
;
;
INIT ; initialization for list manager list
D INIT^RCDPAPLI
Q
;
;
DIQ340(DA,DR) ; diq call to retrieve data for dr fields in file 340
N D0,DIC,DIQ,DIQ2
K RCDPDATA(340,DA)
S DIQ(0)="IE",DIC="^RCD(340,",DIQ="RCDPDATA" D EN^DIQ1
Q
;
;
HDR ; header code for list manager display
I '$G(RCDEBTDA) S VALMHDR(1)="ACCOUNT NOT selected.",VALMHDR(2)="",VALMHDR(3)="" Q
;
N DATA,IBRX,RCSPACE
S DATA=$$ACCNTHDR(RCDEBTDA)
;
S RCSPACE="",$P(RCSPACE," ",81)=""
S VALMHDR(1)=$E("Account: "_$P(DATA,"^")_$P(DATA,"^",2)_RCSPACE,1,62)_$P(DATA,"^",3)
S VALMHDR(2)=$E(" Addr: "_$P(DATA,"^",4)_", "_$P(DATA,"^",7)_", "_$P(DATA,"^",8)_" "_$P(DATA,"^",9)_RCSPACE,1,58)_" Phone: "_$P(DATA,"^",10)
;
S VALMHDR(3)=RCSPACE
I $P($G(^RCD(340,+RCDEBTDA,0)),"^")["DPT(" D
. S IBRX=$$RXST^IBARXEU(+$P($G(^RCD(340,+RCDEBTDA,0)),"^"),DT)
. S VALMHDR(3)=" RX Copay Exempt: "_$S($P(IBRX,"^")=1:"YES",$P(IBRX,"^")=0:"NO",1:"N/A")_RCSPACE
. I $P(IBRX,U)=1 D
. . N DIC,X,Y
. . S DIC="^IBE(354.2,",DIC(0)="M",X=+$P(IBRX,"^",3)
. . D ^DIC
. . I Y>0 S VALMHDR(3)=$E(VALMHDR(3),1,25)_"("_$P(Y,"^",2)_")"_RCSPACE
S VALMHDR(3)=$E(VALMHDR(3),1,80)
;
S VALMHDR(4)=RCSPACE
I $G(RCTOTAL(1))="" S VALMHDR(4)=" ACCOUNT BALANCE: Unknown"
I $G(RCTOTAL(1))'="" D
. S VALMHDR(4)=" ACCOUNT BALANCE: "_$J($G(RCTOTAL(1))+$G(RCTOTAL(2))+$G(RCTOTAL(3))-$G(RCTOTAL("PP")),0,2)
. S VALMHDR(4)=VALMHDR(4)_" Pending Payments: "_$J($G(RCTOTAL("PP")),0,2)
I $O(^RCD(340,RCDEBTDA,2,0)) S VALMHDR(4)=$E($G(VALMHDR(4))_" ",1,72)_"COMMENT"
;
; highlight account balance
S VALMHDR(4)=IORVON_$E(VALMHDR(4),1,30)_IORVOFF_$E(VALMHDR(4),31,80)
Q
;
;
EXIT ; exit list manager option and clean up
K ^TMP("RCDPAPLM",$J),^TMP("RCDPAPLMX",$J)
Q
;
;
SELACCT() ; select an account (debtor)
; returns -1 for timeout or ^, 0 for no selection, or ien of account
N %,%Y,A1,C,DIC,DIYS,DTOUT,DUOUT,RCRJFLAG,X,Y
F D Q:$G(RCRJFLAG)
. R !!,"Select ACCOUNT or BILL NUMBER: ",X:DTIME
. I '$T S Y=-1,DTOUT=1,RCRJFLAG=1 Q
. I X["^" S Y=-1,DUOUT=1,RCRJFLAG=1 Q
. I X="" S Y=0,RCRJFLAG=1 Q
. ;
. ; lookup bill
. S Y=$O(^PRCA(430,"B",X,0)) I 'Y S Y=$O(^PRCA(430,"D",X,0))
. I Y,$P($G(^PRCA(430,Y,0)),"^",9) S Y=$P(^(0),"^",9),^DISV(DUZ,"^PRCA(430,")=Y,RCRJFLAG=1 Q
. ;
. ; lookup account
. S DIC="^RCD(340,",DIC(0)="E"
. D ^DIC
. I Y'<0 S RCRJFLAG=1
I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0
Q +Y
;
;
ACCNTHDR(RCDEBTDA) ; return account data (for headings)
I '$G(RCDEBTDA) Q ""
;
N ADDRESS,DOB,RCDPDATA,SSN,Y
D DIQ340(RCDEBTDA,.01)
;
; get SSN and DOB if applicable
S SSN="",DOB=""
I RCDPDATA(340,RCDEBTDA,.01,"I")["DPT" D
. S SSN="("_$P($G(^DPT(+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",9)_")"
. S Y=$P($G(^DPT(+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",3) I Y D DD^%DT
. S DOB="DOB: "_Y
I RCDPDATA(340,RCDEBTDA,.01,"I")["VA(" D
. S SSN="("_$P($G(^VA(200,+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",9)_")"
. S Y=$P($G(^VA(200,+RCDPDATA(340,RCDEBTDA,.01,"I"),1)),"^",3) I Y D DD^%DT
. S DOB="DOB: "_Y
;
S ADDRESS=$$DADD^RCAMADD(RCDPDATA(340,RCDEBTDA,.01,"I"))
I $P(ADDRESS,"^")="" S $P(ADDRESS,"^")="NO STREET"
I $P(ADDRESS,"^",4)="" S $P(ADDRESS,"^",4)="NO CITY"
I $P(ADDRESS,"^",5)="" S $P(ADDRESS,"^",5)="NO STATE"
I $P(ADDRESS,"^",6)="" S $P(ADDRESS,"^",6)="NO ZIP"
;
; account name ^ ssn ^ dob ^ street1 ^ street2 ^ street3 ^ city
; ^ state ^ zip ^ phone
Q RCDPDATA(340,RCDEBTDA,.01,"E")_"^"_SSN_"^"_DOB_"^"_ADDRESS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPAPLM 4368 printed Dec 13, 2024@01:43:49 Page 2
RCDPAPLM ;WISC/RFJ-account profile top list manager routine ;1 Jun 99
+1 ;;4.5;Accounts Receivable;**114**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 NEW RCDPFXIT
+5 ;
ACCTPROF ; this entry point called by link payment to prevent newing
+1 ; the fast exit variable RCDPFXIT
+2 NEW RCDEBTDA
+3 ;
+4 ; check to see if user has any selected status's to display,
+5 ; if not, set up the default status's
+6 IF $GET(^DISV(DUZ,"RCDPAPLM","STATUS"))=""
DO DEFAULT^RCDPAPST
+7 ;
+8 FOR
Begin DoDot:1
+9 WRITE !!
SET RCDEBTDA=$$SELACCT
+10 IF RCDEBTDA<1
SET RCDEBTDA=0
QUIT
+11 DO EN^VALM("RCDP ACCOUNT PROFILE")
+12 ; fast exit
+13 IF $GET(RCDPFXIT)
SET RCDEBTDA=0
End DoDot:1
if 'RCDEBTDA
QUIT
+14 QUIT
+15 ;
+16 ;
INIT ; initialization for list manager list
+1 DO INIT^RCDPAPLI
+2 QUIT
+3 ;
+4 ;
DIQ340(DA,DR) ; diq call to retrieve data for dr fields in file 340
+1 NEW D0,DIC,DIQ,DIQ2
+2 KILL RCDPDATA(340,DA)
+3 SET DIQ(0)="IE"
SET DIC="^RCD(340,"
SET DIQ="RCDPDATA"
DO EN^DIQ1
+4 QUIT
+5 ;
+6 ;
HDR ; header code for list manager display
+1 IF '$GET(RCDEBTDA)
SET VALMHDR(1)="ACCOUNT NOT selected."
SET VALMHDR(2)=""
SET VALMHDR(3)=""
QUIT
+2 ;
+3 NEW DATA,IBRX,RCSPACE
+4 SET DATA=$$ACCNTHDR(RCDEBTDA)
+5 ;
+6 SET RCSPACE=""
SET $PIECE(RCSPACE," ",81)=""
+7 SET VALMHDR(1)=$EXTRACT("Account: "_$PIECE(DATA,"^")_$PIECE(DATA,"^",2)_RCSPACE,1,62)_$PIECE(DATA,"^",3)
+8 SET VALMHDR(2)=$EXTRACT(" Addr: "_$PIECE(DATA,"^",4)_", "_$PIECE(DATA,"^",7)_", "_$PIECE(DATA,"^",8)_" "_$PIECE(DATA,"^",9)_RCSPACE,1,58)_" Phone: "_$PIECE(DATA,"^",10)
+9 ;
+10 SET VALMHDR(3)=RCSPACE
+11 IF $PIECE($GET(^RCD(340,+RCDEBTDA,0)),"^")["DPT("
Begin DoDot:1
+12 SET IBRX=$$RXST^IBARXEU(+$PIECE($GET(^RCD(340,+RCDEBTDA,0)),"^"),DT)
+13 SET VALMHDR(3)=" RX Copay Exempt: "_$SELECT($PIECE(IBRX,"^")=1:"YES",$PIECE(IBRX,"^")=0:"NO",1:"N/A")_RCSPACE
+14 IF $PIECE(IBRX,U)=1
Begin DoDot:2
+15 NEW DIC,X,Y
+16 SET DIC="^IBE(354.2,"
SET DIC(0)="M"
SET X=+$PIECE(IBRX,"^",3)
+17 DO ^DIC
+18 IF Y>0
SET VALMHDR(3)=$EXTRACT(VALMHDR(3),1,25)_"("_$PIECE(Y,"^",2)_")"_RCSPACE
End DoDot:2
End DoDot:1
+19 SET VALMHDR(3)=$EXTRACT(VALMHDR(3),1,80)
+20 ;
+21 SET VALMHDR(4)=RCSPACE
+22 IF $GET(RCTOTAL(1))=""
SET VALMHDR(4)=" ACCOUNT BALANCE: Unknown"
+23 IF $GET(RCTOTAL(1))'=""
Begin DoDot:1
+24 SET VALMHDR(4)=" ACCOUNT BALANCE: "_$JUSTIFY($GET(RCTOTAL(1))+$GET(RCTOTAL(2))+$GET(RCTOTAL(3))-$GET(RCTOTAL("PP")),0,2)
+25 SET VALMHDR(4)=VALMHDR(4)_" Pending Payments: "_$JUSTIFY($GET(RCTOTAL("PP")),0,2)
End DoDot:1
+26 IF $ORDER(^RCD(340,RCDEBTDA,2,0))
SET VALMHDR(4)=$EXTRACT($GET(VALMHDR(4))_" ",1,72)_"COMMENT"
+27 ;
+28 ; highlight account balance
+29 SET VALMHDR(4)=IORVON_$EXTRACT(VALMHDR(4),1,30)_IORVOFF_$EXTRACT(VALMHDR(4),31,80)
+30 QUIT
+31 ;
+32 ;
EXIT ; exit list manager option and clean up
+1 KILL ^TMP("RCDPAPLM",$JOB),^TMP("RCDPAPLMX",$JOB)
+2 QUIT
+3 ;
+4 ;
SELACCT() ; select an account (debtor)
+1 ; returns -1 for timeout or ^, 0 for no selection, or ien of account
+2 NEW %,%Y,A1,C,DIC,DIYS,DTOUT,DUOUT,RCRJFLAG,X,Y
+3 FOR
Begin DoDot:1
+4 READ !!,"Select ACCOUNT or BILL NUMBER: ",X:DTIME
+5 IF '$TEST
SET Y=-1
SET DTOUT=1
SET RCRJFLAG=1
QUIT
+6 IF X["^"
SET Y=-1
SET DUOUT=1
SET RCRJFLAG=1
QUIT
+7 IF X=""
SET Y=0
SET RCRJFLAG=1
QUIT
+8 ;
+9 ; lookup bill
+10 SET Y=$ORDER(^PRCA(430,"B",X,0))
IF 'Y
SET Y=$ORDER(^PRCA(430,"D",X,0))
+11 IF Y
IF $PIECE($GET(^PRCA(430,Y,0)),"^",9)
SET Y=$PIECE(^(0),"^",9)
SET ^DISV(DUZ,"^PRCA(430,")=Y
SET RCRJFLAG=1
QUIT
+12 ;
+13 ; lookup account
+14 SET DIC="^RCD(340,"
SET DIC(0)="E"
+15 DO ^DIC
+16 IF Y'<0
SET RCRJFLAG=1
End DoDot:1
if $GET(RCRJFLAG)
QUIT
+17 IF Y<0
IF '$GET(DUOUT)
IF '$GET(DTOUT)
SET Y=0
+18 QUIT +Y
+19 ;
+20 ;
ACCNTHDR(RCDEBTDA) ; return account data (for headings)
+1 IF '$GET(RCDEBTDA)
QUIT ""
+2 ;
+3 NEW ADDRESS,DOB,RCDPDATA,SSN,Y
+4 DO DIQ340(RCDEBTDA,.01)
+5 ;
+6 ; get SSN and DOB if applicable
+7 SET SSN=""
SET DOB=""
+8 IF RCDPDATA(340,RCDEBTDA,.01,"I")["DPT"
Begin DoDot:1
+9 SET SSN="("_$PIECE($GET(^DPT(+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",9)_")"
+10 SET Y=$PIECE($GET(^DPT(+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",3)
IF Y
DO DD^%DT
+11 SET DOB="DOB: "_Y
End DoDot:1
+12 IF RCDPDATA(340,RCDEBTDA,.01,"I")["VA("
Begin DoDot:1
+13 SET SSN="("_$PIECE($GET(^VA(200,+RCDPDATA(340,RCDEBTDA,.01,"I"),0)),"^",9)_")"
+14 SET Y=$PIECE($GET(^VA(200,+RCDPDATA(340,RCDEBTDA,.01,"I"),1)),"^",3)
IF Y
DO DD^%DT
+15 SET DOB="DOB: "_Y
End DoDot:1
+16 ;
+17 SET ADDRESS=$$DADD^RCAMADD(RCDPDATA(340,RCDEBTDA,.01,"I"))
+18 IF $PIECE(ADDRESS,"^")=""
SET $PIECE(ADDRESS,"^")="NO STREET"
+19 IF $PIECE(ADDRESS,"^",4)=""
SET $PIECE(ADDRESS,"^",4)="NO CITY"
+20 IF $PIECE(ADDRESS,"^",5)=""
SET $PIECE(ADDRESS,"^",5)="NO STATE"
+21 IF $PIECE(ADDRESS,"^",6)=""
SET $PIECE(ADDRESS,"^",6)="NO ZIP"
+22 ;
+23 ; account name ^ ssn ^ dob ^ street1 ^ street2 ^ street3 ^ city
+24 ; ^ state ^ zip ^ phone
+25 QUIT RCDPDATA(340,RCDEBTDA,.01,"E")_"^"_SSN_"^"_DOB_"^"_ADDRESS
