PRCAAPR ;WASH-ISC@ALTOONA,PA/RGY - PATIENT ACCOUNT PROFILE (CONT) ;3/9/94 8:41 AM
V ;;4.5;Accounts Receivable;**198,221,276,389**;Mar 20, 1995;Build 36
;;Per VHA Directive 2004-038, this routine should not be modified.
EN(PRCATY) ;
NEW DIC,X,Y,DEBT,PRCADB,DA,PRCA,COUNT,OUT,SEL,BILL,BAT,TRAN,DR,DXS,DTOUT,DIROUT,DIRUT,DUOUT
ASK N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
; PRCA*4.5*276, add blank line before prompt for easier use
K OUT S COUNT=0 R !!,"Select DEBTOR NAME or BILL NUMBER: ",X:DTIME I "^"[$E(X) S $P(DEBT,"^",2)="" G Q
S X=$$UPPER^VALM1(X)
S Y=$S($O(^PRCA(430,"B",X,0)):$O(^(0)),$O(^PRCA(430,"D",X,0)):$O(^(0)),1:-1)
I Y>0 S DEBT=$P($G(^PRCA(430,Y,0)),"^",9) I DEBT S PRCADB=$P($G(^RCD(340,DEBT,0)),"^"),^DISV(DUZ,"^PRCA(430,")=Y,$P(DEBT,"^",2)=$$NAM^RCFN01(DEBT) D COMP,EN1^PRCAATR(Y) G:$D(DTOUT) Q G ASK
S DIC="^RCD(340,",DIC(0)="E" D ^DIC G:Y<0 ASK
S ^DISV(DUZ,"^RCD(340,")=+Y,PRCADB=$P(Y,"^",2),DEBT=+Y_"^"_$P(@("^"_$P(PRCADB,";",2)_+PRCADB_",0)"),"^")
D COMP,HDR^PRCAAPR1,HDR2^PRCAAPR1,DIS^PRCAAPR1 G:'$D(DTOUT) ASK
Q K ^TMP("PRCAAPR",$J) Q
;
EN1(DBTR) ; entry point from repayment plan worklist, called from ^RCRPWL1 PRCA*4.5*389
;
; DBTR - file 340 ien
;
N BAT,BILL,COUNT,DEBT,PRCADB,PRCATY,OUT,TRAN,X,Y,Z
K ^TMP("PRCAAPR",$J)
S PRCATY="ALL",COUNT=0
S PRCADB=$P($G(^RCD(340,DBTR,0)),U) ; field 340/.01
S ^DISV(DUZ,"^RCD(340,")=DBTR
S DEBT=DBTR_U_$P(@(U_$P(PRCADB,";",2)_+PRCADB_",0)"),U) ; file 340 ien ^ debtor name
D COMP,HDR^PRCAAPR1,HDR2^PRCAAPR1,DIS^PRCAAPR1
K ^TMP("PRCAAPR",$J)
Q
;
COMP ;Compile patient bills
K ^TMP("PRCAAPR",$J)
NEW STAT,STAT1,CNT,Y
S STAT1=0
F CNT=1:1 S STAT1=+$S(PRCATY="ALL":$O(^PRCA(430,"AS",+DEBT,STAT1)),1:$O(^PRCA(430.3,"AC",+$P(PRCATY,",",CNT),0))) Q:'STAT1 F BILL=0:0 S BILL=$O(^PRCA(430,"AS",+DEBT,STAT1,BILL)) Q:'BILL D COMP1
I PRCADB[";DPT(" F BILL=0:0 S BILL=$O(^PRCA(430,"E",+PRCADB,BILL)) Q:'BILL I PRCATY="ALL"!((","_PRCATY_",")[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(430,BILL,0)),"^",8),0)),"^",3)_",")) D COMP1
F BAT=0:0 S BAT=$O(^RCY(344,"AC",PRCADB,BAT)) Q:'BAT F TRAN=0:0 S TRAN=$O(^RCY(344,"AC",PRCADB,BAT,TRAN)) Q:'TRAN I $G(^RCY(344,BAT,1,TRAN,0))]"",$P(^(0),"^",5)="" D COMP2
Q
COMP1 S STAT=$P($G(^PRCA(430.3,+$P($G(^PRCA(430,BILL,0)),"^",8),0)),"^",3) Q:STAT=""
S X=$G(^PRCA(430,BILL,7)),Y=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
I $P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)) S Y=-Y
S Y=$S($P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0))&(STAT'=112):0,$P(^PRCA(430,BILL,0),"^",9)'=+DEBT:0,",102,107,112,"[(","_STAT_","):Y,1:0)
S ^TMP("PRCAAPR",$J,"C")=$G(^TMP("PRCAAPR",$J,"C"))+Y
S ^TMP("PRCAAPR",$J,"C",STAT)=$G(^TMP("PRCAAPR",$J,"C",STAT))+Y_"^"_STAT,^(STAT,BILL)=$P(X,"^",1,5)
Q
COMP2 ;Compile payments
S Y=$P(^RCY(344,BAT,1,TRAN,0),"^",4)
S ^TMP("PRCAAPR",$J,"C")=$G(^TMP("PRCAAPR",$J,"C"))-Y
S ^TMP("PRCAAPR",$J,"C",99)=$G(^TMP("PRCAAPR",$J,"C",99))-Y_"^99",^TMP("PRCAAPR",$J,"C",99,$P(^RCY(344,BAT,0),"^")_"-"_TRAN)=$P(^RCY(344,BAT,1,TRAN,0),"^",4)
Q
;
COMP3(RCBILL) ; PRCA*4.5*276
; Check for 1st and 3rd party payment activity on bill
; RCBILL is the IEN for the bill # in files #399/#430 and must be valid,
; check the EOB type and exclude it if it is an MRA. Otherwise,
; returns the EEOB indicator '%' if payment activity was found.
; Access to file #361.1 covered by IA #4051.
; Access to file #399 covered by IA #3820.
N PRCOUT,PRCVAL,Z
I $G(RCBILL)=0 Q ""
I '$O(^IBM(361.1,"B",RCBILL,0)) Q "" ; no entry here
I $P($G(^DGCR(399,RCBILL,0)),"^",13)=1 Q "" ;avoid 'ENTERED/NOT REVIEWED' status
; handle both single and multiple bill entries in file #361.1
S Z=0 F S Z=$O(^IBM(361.1,"B",RCBILL,Z)) Q:'Z D Q:$G(PRCOUT)="%"
. S PRCVAL=$G(^IBM(361.1,Z,0))
. S PRCOUT=$S($P(PRCVAL,"^",4)=1:"",$P(PRCVAL,"^",4)=0:"%",1:"")
Q PRCOUT ; EOB indicator for either 1st or 3rd party payment on bill
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAAPR 3944 printed Dec 13, 2024@01:38:53 Page 2
PRCAAPR ;WASH-ISC@ALTOONA,PA/RGY - PATIENT ACCOUNT PROFILE (CONT) ;3/9/94 8:41 AM
V ;;4.5;Accounts Receivable;**198,221,276,389**;Mar 20, 1995;Build 36
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN(PRCATY) ;
+1 NEW DIC,X,Y,DEBT,PRCADB,DA,PRCA,COUNT,OUT,SEL,BILL,BAT,TRAN,DR,DXS,DTOUT,DIROUT,DIRUT,DUOUT
ASK NEW DPTNOFZY,DPTNOFZK
SET (DPTNOFZY,DPTNOFZK)=1
+1 ; PRCA*4.5*276, add blank line before prompt for easier use
+2 KILL OUT
SET COUNT=0
READ !!,"Select DEBTOR NAME or BILL NUMBER: ",X:DTIME
IF "^"[$EXTRACT(X)
SET $PIECE(DEBT,"^",2)=""
GOTO Q
+3 SET X=$$UPPER^VALM1(X)
+4 SET Y=$SELECT($ORDER(^PRCA(430,"B",X,0)):$ORDER(^(0)),$ORDER(^PRCA(430,"D",X,0)):$ORDER(^(0)),1:-1)
+5 IF Y>0
SET DEBT=$PIECE($GET(^PRCA(430,Y,0)),"^",9)
IF DEBT
SET PRCADB=$PIECE($GET(^RCD(340,DEBT,0)),"^")
SET ^DISV(DUZ,"^PRCA(430,")=Y
SET $PIECE(DEBT,"^",2)=$$NAM^RCFN01(DEBT)
DO COMP
DO EN1^PRCAATR(Y)
if $DATA(DTOUT)
GOTO Q
GOTO ASK
+6 SET DIC="^RCD(340,"
SET DIC(0)="E"
DO ^DIC
if Y<0
GOTO ASK
+7 SET ^DISV(DUZ,"^RCD(340,")=+Y
SET PRCADB=$PIECE(Y,"^",2)
SET DEBT=+Y_"^"_$PIECE(@("^"_$PIECE(PRCADB,";",2)_+PRCADB_",0)"),"^")
+8 DO COMP
DO HDR^PRCAAPR1
DO HDR2^PRCAAPR1
DO DIS^PRCAAPR1
if '$DATA(DTOUT)
GOTO ASK
Q KILL ^TMP("PRCAAPR",$JOB)
QUIT
+1 ;
EN1(DBTR) ; entry point from repayment plan worklist, called from ^RCRPWL1 PRCA*4.5*389
+1 ;
+2 ; DBTR - file 340 ien
+3 ;
+4 NEW BAT,BILL,COUNT,DEBT,PRCADB,PRCATY,OUT,TRAN,X,Y,Z
+5 KILL ^TMP("PRCAAPR",$JOB)
+6 SET PRCATY="ALL"
SET COUNT=0
+7 ; field 340/.01
SET PRCADB=$PIECE($GET(^RCD(340,DBTR,0)),U)
+8 SET ^DISV(DUZ,"^RCD(340,")=DBTR
+9 ; file 340 ien ^ debtor name
SET DEBT=DBTR_U_$PIECE(@(U_$PIECE(PRCADB,";",2)_+PRCADB_",0)"),U)
+10 DO COMP
DO HDR^PRCAAPR1
DO HDR2^PRCAAPR1
DO DIS^PRCAAPR1
+11 KILL ^TMP("PRCAAPR",$JOB)
+12 QUIT
+13 ;
COMP ;Compile patient bills
+1 KILL ^TMP("PRCAAPR",$JOB)
+2 NEW STAT,STAT1,CNT,Y
+3 SET STAT1=0
+4 FOR CNT=1:1
SET STAT1=+$SELECT(PRCATY="ALL":$ORDER(^PRCA(430,"AS",+DEBT,STAT1)),1:$ORDER(^PRCA(430.3,"AC",+$PIECE(PRCATY,",",CNT),0)))
if 'STAT1
QUIT
FOR BILL=0:0
SET BILL=$ORDER(^PRCA(430,"AS",+DEBT,STAT1,BILL))
if 'BILL
QUIT
DO COMP1
+5 IF PRCADB[";DPT("
FOR BILL=0:0
SET BILL=$ORDER(^PRCA(430,"E",+PRCADB,BILL))
if 'BILL
QUIT
IF PRCATY="ALL"!((","_PRCATY_",")[(","_$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,BILL,0)),"^",8),0)),"^",3)_","))
DO COMP1
+6 FOR BAT=0:0
SET BAT=$ORDER(^RCY(344,"AC",PRCADB,BAT))
if 'BAT
QUIT
FOR TRAN=0:0
SET TRAN=$ORDER(^RCY(344,"AC",PRCADB,BAT,TRAN))
if 'TRAN
QUIT
IF $GET(^RCY(344,BAT,1,TRAN,0))]""
IF $PIECE(^(0),"^",5)=""
DO COMP2
+7 QUIT
COMP1 SET STAT=$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,BILL,0)),"^",8),0)),"^",3)
if STAT=""
QUIT
+1 SET X=$GET(^PRCA(430,BILL,7))
SET Y=$PIECE(X,"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)
+2 IF $PIECE(^PRCA(430,BILL,0),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0))
SET Y=-Y
+3 SET Y=$SELECT($PIECE(^PRCA(430,BILL,0),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0))&(STAT'=112):0,$PIECE(^PRCA(430,BILL,0),"^",9)'=+DEBT:0,",102,107,112,"[(","_STAT_","):Y,1:0)
+4 SET ^TMP("PRCAAPR",$JOB,"C")=$GET(^TMP("PRCAAPR",$JOB,"C"))+Y
+5 SET ^TMP("PRCAAPR",$JOB,"C",STAT)=$GET(^TMP("PRCAAPR",$JOB,"C",STAT))+Y_"^"_STAT
SET ^(STAT,BILL)=$PIECE(X,"^",1,5)
+6 QUIT
COMP2 ;Compile payments
+1 SET Y=$PIECE(^RCY(344,BAT,1,TRAN,0),"^",4)
+2 SET ^TMP("PRCAAPR",$JOB,"C")=$GET(^TMP("PRCAAPR",$JOB,"C"))-Y
+3 SET ^TMP("PRCAAPR",$JOB,"C",99)=$GET(^TMP("PRCAAPR",$JOB,"C",99))-Y_"^99"
SET ^TMP("PRCAAPR",$JOB,"C",99,$PIECE(^RCY(344,BAT,0),"^")_"-"_TRAN)=$PIECE(^RCY(344,BAT,1,TRAN,0),"^",4)
+4 QUIT
+5 ;
COMP3(RCBILL) ; PRCA*4.5*276
+1 ; Check for 1st and 3rd party payment activity on bill
+2 ; RCBILL is the IEN for the bill # in files #399/#430 and must be valid,
+3 ; check the EOB type and exclude it if it is an MRA. Otherwise,
+4 ; returns the EEOB indicator '%' if payment activity was found.
+5 ; Access to file #361.1 covered by IA #4051.
+6 ; Access to file #399 covered by IA #3820.
+7 NEW PRCOUT,PRCVAL,Z
+8 IF $GET(RCBILL)=0
QUIT ""
+9 ; no entry here
IF '$ORDER(^IBM(361.1,"B",RCBILL,0))
QUIT ""
+10 ;avoid 'ENTERED/NOT REVIEWED' status
IF $PIECE($GET(^DGCR(399,RCBILL,0)),"^",13)=1
QUIT ""
+11 ; handle both single and multiple bill entries in file #361.1
+12 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,"B",RCBILL,Z))
if 'Z
QUIT
Begin DoDot:1
+13 SET PRCVAL=$GET(^IBM(361.1,Z,0))
+14 SET PRCOUT=$SELECT($PIECE(PRCVAL,"^",4)=1:"",$PIECE(PRCVAL,"^",4)=0:"%",1:"")
End DoDot:1
if $GET(PRCOUT)="%"
QUIT
+15 ; EOB indicator for either 1st or 3rd party payment on bill
QUIT PRCOUT
