PRCAI134 ;WASH-ISC@ALTOONA,PA/LDB-Reset Waived in Full Transactions;1/7/99 11:00 AM
V ;;4.5;Accounts Receivable;**134**;Mar 20, 1995
;
EN ;Loop thru waived in full transactions and reset principal amount
N AMT,BN,DAT,PRIN,TR,TR0,TR4,TR40
S DAT=0 F S DAT=$O(^PRCA(433,"AT",10,DAT)) Q:'DAT D
.S TR=0 F S TR=$O(^PRCA(433,"AT",10,DAT,TR)) Q:'TR D
..S TR0=$G(^PRCA(433,+TR,0)) Q:'TR0 S BN=$P(TR0,"^",2) Q:'BN
..I '$O(^PRCA(433,"C",BN,TR)) D CHK
D CHK2
Q
;
CHK ;Check amount in 4 node of 433
S PRIN=$P($G(^PRCA(430,+BN,7)),"^") Q:'PRIN
S TR4=0 S TR4=$O(^PRCA(433,+TR,4,TR4)) Q:'TR4
S TR40=$G(^PRCA(433,+TR,4,TR4,0)) Q:TR40=""
S AMT=$P(TR40,"^",5) Q:AMT=PRIN
S $P(^PRCA(433,+TR,4,TR4,0),"^",5)=PRIN
; update the fy current prin balance in 430
I $D(^PRCA(430,BN,2,TR4,0)) S $P(^PRCA(430,BN,2,TR4,0),"^",2)=PRIN
Q
;
CHK2 ;Loop thru ACTIVE and OPEN RX Co-pay and C Means Test bills to reset current principal
N BN,BN0,FY,FY2,PRIN,X
F X=16,23,42 S BN=0 F S BN=$O(^PRCA(430,"AC",X,BN)) Q:'BN D
.S BN0=$G(^PRCA(430,+BN,0)) Q:BN0']"" I ("^23^22^18^")'[("^"_$P(BN0,"^",2)_"^") Q
.S PRIN=$P($G(^PRCA(430,+BN,7)),"^") Q:'PRIN
.S FY=$O(^PRCA(430,+BN,2,0)) Q:'FY
.S FY2=$G(^PRCA(430,+BN,2,FY,0)) Q:FY2']""
.I $P(^PRCA(430,+BN,2,FY,0),"^",2)'=+PRIN S $P(^PRCA(430,+BN,2,FY,0),"^",2)=+PRIN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAI134 1337 printed Nov 22, 2024@16:50:08 Page 2
PRCAI134 ;WASH-ISC@ALTOONA,PA/LDB-Reset Waived in Full Transactions;1/7/99 11:00 AM
V ;;4.5;Accounts Receivable;**134**;Mar 20, 1995
+1 ;
EN ;Loop thru waived in full transactions and reset principal amount
+1 NEW AMT,BN,DAT,PRIN,TR,TR0,TR4,TR40
+2 SET DAT=0
FOR
SET DAT=$ORDER(^PRCA(433,"AT",10,DAT))
if 'DAT
QUIT
Begin DoDot:1
+3 SET TR=0
FOR
SET TR=$ORDER(^PRCA(433,"AT",10,DAT,TR))
if 'TR
QUIT
Begin DoDot:2
+4 SET TR0=$GET(^PRCA(433,+TR,0))
if 'TR0
QUIT
SET BN=$PIECE(TR0,"^",2)
if 'BN
QUIT
+5 IF '$ORDER(^PRCA(433,"C",BN,TR))
DO CHK
End DoDot:2
End DoDot:1
+6 DO CHK2
+7 QUIT
+8 ;
CHK ;Check amount in 4 node of 433
+1 SET PRIN=$PIECE($GET(^PRCA(430,+BN,7)),"^")
if 'PRIN
QUIT
+2 SET TR4=0
SET TR4=$ORDER(^PRCA(433,+TR,4,TR4))
if 'TR4
QUIT
+3 SET TR40=$GET(^PRCA(433,+TR,4,TR4,0))
if TR40=""
QUIT
+4 SET AMT=$PIECE(TR40,"^",5)
if AMT=PRIN
QUIT
+5 SET $PIECE(^PRCA(433,+TR,4,TR4,0),"^",5)=PRIN
+6 ; update the fy current prin balance in 430
+7 IF $DATA(^PRCA(430,BN,2,TR4,0))
SET $PIECE(^PRCA(430,BN,2,TR4,0),"^",2)=PRIN
+8 QUIT
+9 ;
CHK2 ;Loop thru ACTIVE and OPEN RX Co-pay and C Means Test bills to reset current principal
+1 NEW BN,BN0,FY,FY2,PRIN,X
+2 FOR X=16,23,42
SET BN=0
FOR
SET BN=$ORDER(^PRCA(430,"AC",X,BN))
if 'BN
QUIT
Begin DoDot:1
+3 SET BN0=$GET(^PRCA(430,+BN,0))
if BN0']""
QUIT
IF ("^23^22^18^")'[("^"_$PIECE(BN0,"^",2)_"^")
QUIT
+4 SET PRIN=$PIECE($GET(^PRCA(430,+BN,7)),"^")
if 'PRIN
QUIT
+5 SET FY=$ORDER(^PRCA(430,+BN,2,0))
if 'FY
QUIT
+6 SET FY2=$GET(^PRCA(430,+BN,2,FY,0))
if FY2']""
QUIT
+7 IF $PIECE(^PRCA(430,+BN,2,FY,0),"^",2)'=+PRIN
SET $PIECE(^PRCA(430,+BN,2,FY,0),"^",2)=+PRIN
End DoDot:1
+8 QUIT
