PRCAGT ;WASH-ISC@ALTOONA,PA/CMS - Patient Statement Build Tran List ;8/19/93
V ;;4.5;Accounts Receivable;**100,162,165,169,219,301,340,377,381,389**;Mar 20, 1995;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;SEND (DEB=340-IFN,BEG,END,TRANTYPE=430.3-IFN)
;BUILD ^TMP("PRCAGT",$J,DEB,DATE,BILL,TN)=TAMT^TTY
;IF (TN,TTY)=0 TAMT=BILL'S ORIG AMT
;CALLER MUST KILL ^TMP
EN(DEB,BEG,END,TTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
NEW Y,% K ^TMP("PRCAGT",$J)
S:$G(BEG)="" BEG=0 I $G(END)="" D NOW^%DTC S END=%
S TTY=$G(TTY) I TTY="" D F430
D F433
Q Q
F430 ;
NEW DAT,BN
S DAT=BEG F S DAT=$O(^PRCA(430,"ATD",DEB,DAT)) Q:('DAT)!(DAT>END) S BN=0 F S BN=$O(^PRCA(430,"ATD",DEB,DAT,BN)) Q:'BN D
.;Q:$D(^PRCA(430,"TCSP",BN)) ;prca*4.5*301
.I $P(^PRCA(430,BN,0),U,3) S ^TMP("PRCAGT",$J,DEB,DAT,BN,0)=$P(^PRCA(430,BN,0),"^",3)_"^0"
Q
F433 ;
NEW DAT,TN,TN0,TN1,COMM S COMM=0
F DAT=BEG:0 S DAT=$O(^PRCA(433,"ATD",DEB,DAT)) Q:('DAT)!(DAT>END) F TN=0:0 S TN=$O(^PRCA(433,"ATD",DEB,DAT,TN)) Q:'TN D
.S TN0=$G(^PRCA(433,TN,0)) Q:TN0="" S TN1=$G(^PRCA(433,TN,1))
.I $P(TN1,U,2)=45 S COMM=1
.I $G(TTY)'="" Q:TTY'=$P(TN1,U,2)
.;PRCA*4.5*377/PRCA*4.5*381/PRCA*4.5*389
.I TTY="",",3,4,5,6,7,24,30,"[(","_$P(TN1,U,2)_",") Q
.I ($P(TN0,U,2)="")!($P(TN0,U,4)'=2) Q
.I $G(PRCAHIST)="THIST",$P(TN1,U,2)=45 G F433A
.I $P(TN0,U,10)=1 Q
.;
.; if transaction type not 46 (unsuspended) and not 47 (suspended)
.; then check to see if the bill was suspended or unsuspended at the
.; time the transaction was entered. if the bill is suspended, then
.; the transaction should not be counted. if the bill is unsuspended
.; then the transaction should be counted.
.I $P(TN1,"^",2)'=46,$P(TN1,"^",2)'=47 D I TN1="" Q
. . N RCTRANDA,RCSTOP,TRANTYPE
. . ; check to see if bill was unsuspended when transaction was created
. . ; if so, count the transaction
. . S RCSTOP=0
. . S RCTRANDA=TN F S RCTRANDA=$O(^PRCA(433,"C",+$P(TN0,"^",2),RCTRANDA),-1) Q:'RCTRANDA D I RCSTOP Q
. . . ; transaction not complete
. . . I $P($G(^PRCA(433,RCTRANDA,0)),"^",4)'=2 Q
. . . S TRANTYPE=$P($G(^PRCA(433,RCTRANDA,1)),"^",2)
. . . ; transaction type is unsuspended (46) meaning the bill
. . . ; was unsuspended when the transaction was created. the
. . . ; transaction should be counted.
. . . I TRANTYPE=46 S RCSTOP=1 Q
. . . ; transaction type is suspended (47) meaning the bill
. . . ; was suspended when the transaction was created. the
. . . ; transaction should not be counted.
. . . I TRANTYPE=47 S RCSTOP=1,TN1="" Q
.;
.I TTY="",+$P(TN1,U,5)=0,$P(TN1,U,2)'=45 Q
F433A .S ^TMP("PRCAGT",$J,DEB,DAT,$P(TN0,U,2),TN)=+$P(TN1,U,5)_U_$P(TN1,U,2)
S DAT=0 F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S END=DAT
Q
TBAL(DEB,TBAL) ;get balance of transactions
NEW BN,CH,DAT,PC,RF,RR,TAMT,TN,TTY,CS,CSFLAG
S RR=+$O(^PRCA(430.2,"AC",33,0)),(CH,RF,PC)=0,CSFLAG=$D(CSTCH)
I '$D(^TMP("PRCAGT",$J,DEB)) G TBALQ
F DAT=0:0 S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT F BN=0:0 S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D
.S CS=$D(^PRCA(430,"TCSP",BN)) ; set flag for CS bills
.I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S CH=CH+^(0) S:CS CSTCH=$G(CSTCH)+^(0)
.F TN=0:0 S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S TAMT=^(TN),TTY=$P(TAMT,U,2) I TTY'=45 D
..I TTY=12!(TTY=74) S:TAMT<0 PC=PC+TAMT S:TAMT'<0 CH=CH+TAMT S:TAMT<0&CS CSTPC=$G(CSTPC)+TAMT S:TAMT'<0 CSTCH=$G(CSTCH)+TAMT
..; interest and admin charges may be negative
..; this was added in patch 165
..I TTY'=13 S TAMT=$TR(+TAMT,"-")
..I $P(^PRCA(430,BN,0),U,2)=RR S:TTY=1 PC=PC-TAMT S:TTY=35 CH=CH+TAMT S:TTY=41 RF=RF+TAMT Q
..I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") S PC=PC-TAMT S:CS CSTPC=$G(CSTPC)-TAMT Q
..I ",1,13,46,43,73,"[(","_TTY_",") S CH=CH+TAMT S:CS CSTCH=$G(CSTCH)+TAMT
;
TBALQ S TBAL("RF")=RF,TBAL("CH")=CH,TBAL("PC")=PC,TBAL=RF+CH+PC
I 'CSFLAG K CSTCH,CSTPC
Q
ACT(DEB,DAT) ;Quit 1 if debtor has activity other than interest
NEW BN,DATT,TN,TN0,TN1
S TN=0 F DATT=$P($G(DAT),"."):0 S DATT=$O(^PRCA(430,"ATD",DEB,DATT)) Q:'DATT!(TN) F BN=0:0 S BN=$O(^PRCA(430,"ATD",DEB,DATT,BN)) Q:'BN!(TN) S TN=1 Q
I TN=1 G Q1
S BN=0 F DATT=$P($G(DAT),"."):0 S DATT=$O(^PRCA(433,"ATD",DEB,DATT)) Q:'DATT!(BN) F TN=0:0 S TN=$O(^PRCA(433,"ATD",DEB,DATT,TN)) Q:'TN!(BN) D
.S TN0=$G(^PRCA(433,TN,0)) Q:TN0="" S TN1=$G(^PRCA(433,TN,1))
.I ($P(TN0,U,4)=1)!($P(TN0,U,10)=1) Q
.I +$P(TN1,U,5)=0,$P(TN1,U,2)'=45 Q
.I +$P(TN1,U,2)'=13 S BN=1 Q
I BN=1 G Q1
Q0 Q 0
Q1 Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAGT 4666 printed Oct 16, 2024@17:40:39 Page 2
PRCAGT ;WASH-ISC@ALTOONA,PA/CMS - Patient Statement Build Tran List ;8/19/93
V ;;4.5;Accounts Receivable;**100,162,165,169,219,301,340,377,381,389**;Mar 20, 1995;Build 36
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;SEND (DEB=340-IFN,BEG,END,TRANTYPE=430.3-IFN)
+3 ;BUILD ^TMP("PRCAGT",$J,DEB,DATE,BILL,TN)=TAMT^TTY
+4 ;IF (TN,TTY)=0 TAMT=BILL'S ORIG AMT
+5 ;CALLER MUST KILL ^TMP
EN(DEB,BEG,END,TTY) ;*CALLER MUST KILL ^TMP("PRCAGT",$J)
+1 NEW Y,%
KILL ^TMP("PRCAGT",$JOB)
+2 if $GET(BEG)=""
SET BEG=0
IF $GET(END)=""
DO NOW^%DTC
SET END=%
+3 SET TTY=$GET(TTY)
IF TTY=""
DO F430
+4 DO F433
Q QUIT
F430 ;
+1 NEW DAT,BN
+2 SET DAT=BEG
FOR
SET DAT=$ORDER(^PRCA(430,"ATD",DEB,DAT))
if ('DAT)!(DAT>END)
QUIT
SET BN=0
FOR
SET BN=$ORDER(^PRCA(430,"ATD",DEB,DAT,BN))
if 'BN
QUIT
Begin DoDot:1
+3 ;Q:$D(^PRCA(430,"TCSP",BN)) ;prca*4.5*301
+4 IF $PIECE(^PRCA(430,BN,0),U,3)
SET ^TMP("PRCAGT",$JOB,DEB,DAT,BN,0)=$PIECE(^PRCA(430,BN,0),"^",3)_"^0"
End DoDot:1
+5 QUIT
F433 ;
+1 NEW DAT,TN,TN0,TN1,COMM
SET COMM=0
+2 FOR DAT=BEG:0
SET DAT=$ORDER(^PRCA(433,"ATD",DEB,DAT))
if ('DAT)!(DAT>END)
QUIT
FOR TN=0:0
SET TN=$ORDER(^PRCA(433,"ATD",DEB,DAT,TN))
if 'TN
QUIT
Begin DoDot:1
+3 SET TN0=$GET(^PRCA(433,TN,0))
if TN0=""
QUIT
SET TN1=$GET(^PRCA(433,TN,1))
+4 IF $PIECE(TN1,U,2)=45
SET COMM=1
+5 IF $GET(TTY)'=""
if TTY'=$PIECE(TN1,U,2)
QUIT
+6 ;PRCA*4.5*377/PRCA*4.5*381/PRCA*4.5*389
+7 IF TTY=""
IF ",3,4,5,6,7,24,30,"[(","_$PIECE(TN1,U,2)_",")
QUIT
+8 IF ($PIECE(TN0,U,2)="")!($PIECE(TN0,U,4)'=2)
QUIT
+9 IF $GET(PRCAHIST)="THIST"
IF $PIECE(TN1,U,2)=45
GOTO F433A
+10 IF $PIECE(TN0,U,10)=1
QUIT
+11 ;
+12 ; if transaction type not 46 (unsuspended) and not 47 (suspended)
+13 ; then check to see if the bill was suspended or unsuspended at the
+14 ; time the transaction was entered. if the bill is suspended, then
+15 ; the transaction should not be counted. if the bill is unsuspended
+16 ; then the transaction should be counted.
+17 IF $PIECE(TN1,"^",2)'=46
IF $PIECE(TN1,"^",2)'=47
Begin DoDot:2
+18 NEW RCTRANDA,RCSTOP,TRANTYPE
+19 ; check to see if bill was unsuspended when transaction was created
+20 ; if so, count the transaction
+21 SET RCSTOP=0
+22 SET RCTRANDA=TN
FOR
SET RCTRANDA=$ORDER(^PRCA(433,"C",+$PIECE(TN0,"^",2),RCTRANDA),-1)
if 'RCTRANDA
QUIT
Begin DoDot:3
+23 ; transaction not complete
+24 IF $PIECE($GET(^PRCA(433,RCTRANDA,0)),"^",4)'=2
QUIT
+25 SET TRANTYPE=$PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",2)
+26 ; transaction type is unsuspended (46) meaning the bill
+27 ; was unsuspended when the transaction was created. the
+28 ; transaction should be counted.
+29 IF TRANTYPE=46
SET RCSTOP=1
QUIT
+30 ; transaction type is suspended (47) meaning the bill
+31 ; was suspended when the transaction was created. the
+32 ; transaction should not be counted.
+33 IF TRANTYPE=47
SET RCSTOP=1
SET TN1=""
QUIT
End DoDot:3
IF RCSTOP
QUIT
End DoDot:2
IF TN1=""
QUIT
+34 ;
+35 IF TTY=""
IF +$PIECE(TN1,U,5)=0
IF $PIECE(TN1,U,2)'=45
QUIT
F433A SET ^TMP("PRCAGT",$JOB,DEB,DAT,$PIECE(TN0,U,2),TN)=+$PIECE(TN1,U,5)_U_$PIECE(TN1,U,2)
End DoDot:1
+1 SET DAT=0
FOR
SET DAT=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT))
if 'DAT
QUIT
SET END=DAT
+2 QUIT
TBAL(DEB,TBAL) ;get balance of transactions
+1 NEW BN,CH,DAT,PC,RF,RR,TAMT,TN,TTY,CS,CSFLAG
+2 SET RR=+$ORDER(^PRCA(430.2,"AC",33,0))
SET (CH,RF,PC)=0
SET CSFLAG=$DATA(CSTCH)
+3 IF '$DATA(^TMP("PRCAGT",$JOB,DEB))
GOTO TBALQ
+4 FOR DAT=0:0
SET DAT=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT))
if 'DAT
QUIT
FOR BN=0:0
SET BN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT,BN))
if 'BN
QUIT
Begin DoDot:1
+5 ; set flag for CS bills
SET CS=$DATA(^PRCA(430,"TCSP",BN))
+6 IF $DATA(^TMP("PRCAGT",$JOB,DEB,DAT,BN,0))
SET CH=CH+^(0)
if CS
SET CSTCH=$GET(CSTCH)+^(0)
+7 FOR TN=0:0
SET TN=$ORDER(^TMP("PRCAGT",$JOB,DEB,DAT,BN,TN))
if 'TN
QUIT
SET TAMT=^(TN)
SET TTY=$PIECE(TAMT,U,2)
IF TTY'=45
Begin DoDot:2
+8 IF TTY=12!(TTY=74)
if TAMT<0
SET PC=PC+TAMT
if TAMT'<0
SET CH=CH+TAMT
if TAMT<0&CS
SET CSTPC=$GET(CSTPC)+TAMT
if TAMT'<0
SET CSTCH=$GET(CSTCH)+TAMT
+9 ; interest and admin charges may be negative
+10 ; this was added in patch 165
+11 IF TTY'=13
SET TAMT=$TRANSLATE(+TAMT,"-")
+12 IF $PIECE(^PRCA(430,BN,0),U,2)=RR
if TTY=1
SET PC=PC-TAMT
if TTY=35
SET CH=CH+TAMT
if TTY=41
SET RF=RF+TAMT
QUIT
+13 IF ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",")
SET PC=PC-TAMT
if CS
SET CSTPC=$GET(CSTPC)-TAMT
QUIT
+14 IF ",1,13,46,43,73,"[(","_TTY_",")
SET CH=CH+TAMT
if CS
SET CSTCH=$GET(CSTCH)+TAMT
End DoDot:2
End DoDot:1
+15 ;
TBALQ SET TBAL("RF")=RF
SET TBAL("CH")=CH
SET TBAL("PC")=PC
SET TBAL=RF+CH+PC
+1 IF 'CSFLAG
KILL CSTCH,CSTPC
+2 QUIT
ACT(DEB,DAT) ;Quit 1 if debtor has activity other than interest
+1 NEW BN,DATT,TN,TN0,TN1
+2 SET TN=0
FOR DATT=$PIECE($GET(DAT),"."):0
SET DATT=$ORDER(^PRCA(430,"ATD",DEB,DATT))
if 'DATT!(TN)
QUIT
FOR BN=0:0
SET BN=$ORDER(^PRCA(430,"ATD",DEB,DATT,BN))
if 'BN!(TN)
QUIT
SET TN=1
QUIT
+3 IF TN=1
GOTO Q1
+4 SET BN=0
FOR DATT=$PIECE($GET(DAT),"."):0
SET DATT=$ORDER(^PRCA(433,"ATD",DEB,DATT))
if 'DATT!(BN)
QUIT
FOR TN=0:0
SET TN=$ORDER(^PRCA(433,"ATD",DEB,DATT,TN))
if 'TN!(BN)
QUIT
Begin DoDot:1
+5 SET TN0=$GET(^PRCA(433,TN,0))
if TN0=""
QUIT
SET TN1=$GET(^PRCA(433,TN,1))
+6 IF ($PIECE(TN0,U,4)=1)!($PIECE(TN0,U,10)=1)
QUIT
+7 IF +$PIECE(TN1,U,5)=0
IF $PIECE(TN1,U,2)'=45
QUIT
+8 IF +$PIECE(TN1,U,2)'=13
SET BN=1
QUIT
End DoDot:1
+9 IF BN=1
GOTO Q1
Q0 QUIT 0
Q1 QUIT 1
