PRCAI16A ;WISC/RFJ-post init patch 169 continued ; 1 Apr 01
;;4.5;Accounts Receivable;**169**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
START ; start post init (fix exempt transactions)
; break out the exempt transaction to interest and admin
N RCDATE,RCTRANDA
;
; start finding exempt transactions and fixing them
S RCDATE=9999999 F S RCDATE=$O(^PRCA(433,"AT",14,RCDATE),-1) Q:'RCDATE D
. S RCTRANDA=999999999999999
. F S RCTRANDA=$O(^PRCA(433,"AT",14,RCDATE,RCTRANDA),-1) Q:'RCTRANDA D FIXEXEM(RCTRANDA)
Q
;
;
FIXEXEM(RCTRANDA) ; fix an exempt charge
; if transaction status not valid, quit
I '$$VALID^RCRJRCOT(RCTRANDA) Q
;
N ADMIN,BALANCE,CC,INTEREST,MF,RCBALANC,RCBILLDA,RCDATA7,RCLIST,TRANTOTL
;
L +^PRCA(433,RCTRANDA)
;
; if node 2 already breaks out the int/admin, quit
I $G(^PRCA(433,RCTRANDA,2))'="" L -^PRCA(433,RCTRANDA) Q
;
S RCBILLDA=$P(^PRCA(433,RCTRANDA,0),"^",2)
; no bill on transaction
I 'RCBILLDA L -^PRCA(433,RCTRANDA) Q
;
; lock the bill and get the current bill balance
L +^PRCA(430,RCBILLDA)
S RCBALANC=$$GETTRANS^RCDPBTLM(RCBILLDA)
S TRANTOTL=$P(^PRCA(433,RCTRANDA,1),"^",5) I 'TRANTOTL D UNLOCK Q
;
; if the bill is in balance and the balance is zero,
; make the transaction all interest
I $TR($P(RCBALANC,"^",2,5),"^0")="",$$OUTOFBAL^RCBDBBAL(RCBILLDA)="" S $P(^PRCA(433,RCTRANDA,2),"^",7)=TRANTOTL D UNLOCK Q
;
; if the interest balance is equal to the admin balance and
; the interest balance is zero, move to admin
I $P(RCBALANC,"^",2)<0,-$P(RCBALANC,"^",2)=$P(RCBALANC,"^",3) D Q
. S ADMIN=$P(RCBALANC,"^",3) I ADMIN>TRANTOTL S ADMIN=TRANTOTL
. S INTEREST=TRANTOTL-ADMIN
. S (MF,CC)=0
. D SET
;
; if the stored interest balance minus the calculated
; interest balance is equal to the transaction total
; of the exemption, then the exemption is
; for all admin.
S RCDATA7=$P($G(^PRCA(430,RCBILLDA,7)),"^",1,5)
I ($P(RCDATA7,"^",2)-$P(RCBALANC,"^",2))=TRANTOTL D Q
. S (INTEREST,MF,CC)=0
. S ADMIN=TRANTOTL D SET
;
; calculate the bills balance up to the exempt transaction
S BALANCE=$$CALCBAL(0,RCTRANDA-1)
;
S (INTEREST,ADMIN,MF,CC)=""
S INTEREST=$P(BALANCE,"^",2) I INTEREST<0 S INTEREST=0
I INTEREST'<TRANTOTL S INTEREST=TRANTOTL D SET Q
;
S ADMIN=$P(BALANCE,"^",3) I ADMIN<0 S ADMIN=0
I (INTEREST+ADMIN)'<TRANTOTL S ADMIN=TRANTOTL-INTEREST D SET Q
;
S MF=$P(BALANCE,"^",4) I MF<0 S MF=0
I (INTEREST+ADMIN+MF)'<TRANTOTL S MF=TRANTOTL-INTEREST-ADMIN D SET Q
;
S CC=$P(BALANCE,"^",5) I CC<0 S CC=0
I (INTEREST+ADMIN+MF+CC)'<TRANTOTL S CC=TRANTOTL-INTEREST-ADMIN-MF D SET Q
;
; set as all interest
S INTEREST=TRANTOTL,(ADMIN,MF,CC)="" D SET
Q
;
;
SET ; set the exempt node
N DATA2
S DATA2=$G(^PRCA(433,RCTRANDA,2))
I INTEREST S $P(DATA2,"^",7)=INTEREST
I ADMIN S $P(DATA2,"^",8)=ADMIN
I MF S $P(DATA2,"^",5)=MF
I CC S $P(DATA2,"^",6)=CC
S ^PRCA(433,RCTRANDA,2)=DATA2
D UNLOCK
Q
;
;
UNLOCK ; unlock the transaction and bill
L -^PRCA(433,RCTRANDA)
L -^PRCA(430,RCBILLDA)
Q
;
;
CALCBAL(RCDATE,RCTRANDA) ; calculate a bills balance
; up to a certain date and/or transaction
; rclist(date,tranda) must be defined from calling
; gettrans^rcdpbtlm
;
I 'RCDATE N RCDATE S RCDATE=9999999
I 'RCTRANDA N RCTRANDA S RCTRANDA=999999999999999
;
N ADMBAL,CCBAL,DATE,INTBAL,MFBAL,PRINBAL,TRANDA,RCSTOP
S (PRINBAL,INTBAL,ADMBAL,MFBAL,CCBAL)=0
;
S DATE="" F S DATE=$O(RCLIST(DATE)) Q:DATE=""!($G(RCSTOP)) D
. I $E(DATE,1,7)>$E(RCDATE,1,7) S RCSTOP=1 Q
. ;
. S TRANDA="" F S TRANDA=$O(RCLIST(DATE,TRANDA)) Q:TRANDA="" D
. . I TRANDA>RCTRANDA S RCSTOP=1 Q
. . ;
. . S PRINBAL=PRINBAL+$P(RCLIST(DATE,TRANDA),"^",2)
. . S INTBAL=INTBAL+$P(RCLIST(DATE,TRANDA),"^",3)
. . S ADMBAL=ADMBAL+$P(RCLIST(DATE,TRANDA),"^",4)
. . S MFBAL=MFBAL+$P(RCLIST(DATE,TRANDA),"^",5)
. . S CCBAL=CCBAL+$P(RCLIST(DATE,TRANDA),"^",6)
;
Q PRINBAL_"^"_INTBAL_"^"_ADMBAL_"^"_MFBAL_"^"_CCBAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAI16A 4145 printed Sep 23, 2025@19:16:03 Page 2
PRCAI16A ;WISC/RFJ-post init patch 169 continued ; 1 Apr 01
+1 ;;4.5;Accounts Receivable;**169**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
START ; start post init (fix exempt transactions)
+1 ; break out the exempt transaction to interest and admin
+2 NEW RCDATE,RCTRANDA
+3 ;
+4 ; start finding exempt transactions and fixing them
+5 SET RCDATE=9999999
FOR
SET RCDATE=$ORDER(^PRCA(433,"AT",14,RCDATE),-1)
if 'RCDATE
QUIT
Begin DoDot:1
+6 SET RCTRANDA=999999999999999
+7 FOR
SET RCTRANDA=$ORDER(^PRCA(433,"AT",14,RCDATE,RCTRANDA),-1)
if 'RCTRANDA
QUIT
DO FIXEXEM(RCTRANDA)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
FIXEXEM(RCTRANDA) ; fix an exempt charge
+1 ; if transaction status not valid, quit
+2 IF '$$VALID^RCRJRCOT(RCTRANDA)
QUIT
+3 ;
+4 NEW ADMIN,BALANCE,CC,INTEREST,MF,RCBALANC,RCBILLDA,RCDATA7,RCLIST,TRANTOTL
+5 ;
+6 LOCK +^PRCA(433,RCTRANDA)
+7 ;
+8 ; if node 2 already breaks out the int/admin, quit
+9 IF $GET(^PRCA(433,RCTRANDA,2))'=""
LOCK -^PRCA(433,RCTRANDA)
QUIT
+10 ;
+11 SET RCBILLDA=$PIECE(^PRCA(433,RCTRANDA,0),"^",2)
+12 ; no bill on transaction
+13 IF 'RCBILLDA
LOCK -^PRCA(433,RCTRANDA)
QUIT
+14 ;
+15 ; lock the bill and get the current bill balance
+16 LOCK +^PRCA(430,RCBILLDA)
+17 SET RCBALANC=$$GETTRANS^RCDPBTLM(RCBILLDA)
+18 SET TRANTOTL=$PIECE(^PRCA(433,RCTRANDA,1),"^",5)
IF 'TRANTOTL
DO UNLOCK
QUIT
+19 ;
+20 ; if the bill is in balance and the balance is zero,
+21 ; make the transaction all interest
+22 IF $TRANSLATE($PIECE(RCBALANC,"^",2,5),"^0")=""
IF $$OUTOFBAL^RCBDBBAL(RCBILLDA)=""
SET $PIECE(^PRCA(433,RCTRANDA,2),"^",7)=TRANTOTL
DO UNLOCK
QUIT
+23 ;
+24 ; if the interest balance is equal to the admin balance and
+25 ; the interest balance is zero, move to admin
+26 IF $PIECE(RCBALANC,"^",2)<0
IF -$PIECE(RCBALANC,"^",2)=$PIECE(RCBALANC,"^",3)
Begin DoDot:1
+27 SET ADMIN=$PIECE(RCBALANC,"^",3)
IF ADMIN>TRANTOTL
SET ADMIN=TRANTOTL
+28 SET INTEREST=TRANTOTL-ADMIN
+29 SET (MF,CC)=0
+30 DO SET
End DoDot:1
QUIT
+31 ;
+32 ; if the stored interest balance minus the calculated
+33 ; interest balance is equal to the transaction total
+34 ; of the exemption, then the exemption is
+35 ; for all admin.
+36 SET RCDATA7=$PIECE($GET(^PRCA(430,RCBILLDA,7)),"^",1,5)
+37 IF ($PIECE(RCDATA7,"^",2)-$PIECE(RCBALANC,"^",2))=TRANTOTL
Begin DoDot:1
+38 SET (INTEREST,MF,CC)=0
+39 SET ADMIN=TRANTOTL
DO SET
End DoDot:1
QUIT
+40 ;
+41 ; calculate the bills balance up to the exempt transaction
+42 SET BALANCE=$$CALCBAL(0,RCTRANDA-1)
+43 ;
+44 SET (INTEREST,ADMIN,MF,CC)=""
+45 SET INTEREST=$PIECE(BALANCE,"^",2)
IF INTEREST<0
SET INTEREST=0
+46 IF INTEREST'<TRANTOTL
SET INTEREST=TRANTOTL
DO SET
QUIT
+47 ;
+48 SET ADMIN=$PIECE(BALANCE,"^",3)
IF ADMIN<0
SET ADMIN=0
+49 IF (INTEREST+ADMIN)'<TRANTOTL
SET ADMIN=TRANTOTL-INTEREST
DO SET
QUIT
+50 ;
+51 SET MF=$PIECE(BALANCE,"^",4)
IF MF<0
SET MF=0
+52 IF (INTEREST+ADMIN+MF)'<TRANTOTL
SET MF=TRANTOTL-INTEREST-ADMIN
DO SET
QUIT
+53 ;
+54 SET CC=$PIECE(BALANCE,"^",5)
IF CC<0
SET CC=0
+55 IF (INTEREST+ADMIN+MF+CC)'<TRANTOTL
SET CC=TRANTOTL-INTEREST-ADMIN-MF
DO SET
QUIT
+56 ;
+57 ; set as all interest
+58 SET INTEREST=TRANTOTL
SET (ADMIN,MF,CC)=""
DO SET
+59 QUIT
+60 ;
+61 ;
SET ; set the exempt node
+1 NEW DATA2
+2 SET DATA2=$GET(^PRCA(433,RCTRANDA,2))
+3 IF INTEREST
SET $PIECE(DATA2,"^",7)=INTEREST
+4 IF ADMIN
SET $PIECE(DATA2,"^",8)=ADMIN
+5 IF MF
SET $PIECE(DATA2,"^",5)=MF
+6 IF CC
SET $PIECE(DATA2,"^",6)=CC
+7 SET ^PRCA(433,RCTRANDA,2)=DATA2
+8 DO UNLOCK
+9 QUIT
+10 ;
+11 ;
UNLOCK ; unlock the transaction and bill
+1 LOCK -^PRCA(433,RCTRANDA)
+2 LOCK -^PRCA(430,RCBILLDA)
+3 QUIT
+4 ;
+5 ;
CALCBAL(RCDATE,RCTRANDA) ; calculate a bills balance
+1 ; up to a certain date and/or transaction
+2 ; rclist(date,tranda) must be defined from calling
+3 ; gettrans^rcdpbtlm
+4 ;
+5 IF 'RCDATE
NEW RCDATE
SET RCDATE=9999999
+6 IF 'RCTRANDA
NEW RCTRANDA
SET RCTRANDA=999999999999999
+7 ;
+8 NEW ADMBAL,CCBAL,DATE,INTBAL,MFBAL,PRINBAL,TRANDA,RCSTOP
+9 SET (PRINBAL,INTBAL,ADMBAL,MFBAL,CCBAL)=0
+10 ;
+11 SET DATE=""
FOR
SET DATE=$ORDER(RCLIST(DATE))
if DATE=""!($GET(RCSTOP))
QUIT
Begin DoDot:1
+12 IF $EXTRACT(DATE,1,7)>$EXTRACT(RCDATE,1,7)
SET RCSTOP=1
QUIT
+13 ;
+14 SET TRANDA=""
FOR
SET TRANDA=$ORDER(RCLIST(DATE,TRANDA))
if TRANDA=""
QUIT
Begin DoDot:2
+15 IF TRANDA>RCTRANDA
SET RCSTOP=1
QUIT
+16 ;
+17 SET PRINBAL=PRINBAL+$PIECE(RCLIST(DATE,TRANDA),"^",2)
+18 SET INTBAL=INTBAL+$PIECE(RCLIST(DATE,TRANDA),"^",3)
+19 SET ADMBAL=ADMBAL+$PIECE(RCLIST(DATE,TRANDA),"^",4)
+20 SET MFBAL=MFBAL+$PIECE(RCLIST(DATE,TRANDA),"^",5)
+21 SET CCBAL=CCBAL+$PIECE(RCLIST(DATE,TRANDA),"^",6)
End DoDot:2
End DoDot:1
+22 ;
+23 QUIT PRINBAL_"^"_INTBAL_"^"_ADMBAL_"^"_MFBAL_"^"_CCBAL
