PRCADJ ;SF-ISC/YJK,ALB/CMS - ADJUSTMENT TRANSACTION ;9/7/95 10:58 AM
;;4.5;Accounts Receivable;**21,67,48,89,63,111,123,131,134,169**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
;
UPPRIN ;Update Prin bal
N DA,DIE,DR,X,Y
Q:('$D(PRCABN))!('$D(PRCAMT))
Q:'$D(^PRCA(430,+PRCABN,7))
S PRCAMT("C")=$P(^PRCA(430,+PRCABN,7),U,1)+PRCAMT
S DA=+PRCABN,DIE="^PRCA(430,",DR="71////^S X="_PRCAMT("C") D ^DIE
S (X,PRCAMT("C"))=$G(^PRCA(430,+PRCABN,7))
I ($P($G(^PRCA(430,+$G(PRCABN),0)),"^",2)=$O(^PRCA(430.2,"AC",33,0))),($P($G(^PRCA(430,+PRCABN,0)),U,8)'=$O(^PRCA(430.3,"AC",112,0))) Q
I $P(X,"^",1)+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)=0 D
.S PRCA("SDT")=DT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",111,0))
.D CHK,UPSTATS^PRCAUT2,EOB
S RCREF=$P($G(^PRCA(430,+PRCABN,6)),U,5)
I RCREF]"" D
.S RCREF=$S(RCREF="DC":"RC",1:RCREF)
.S DA=+PRCAEN,DIE="^PRCA(433,",DR="7///^S X=RCREF" D ^DIE
Q
;
EOB ;Another payer bulletin call
I ($P($G(^PRCA(433,+PRCAEN,8)),"^",8)),($P($G(^PRCA(430.2,+$P($G(^PRCA(430,+PRCABN,0)),U,2),0)),U,6)="T") D
.S PRCAMT("O")=$P($G(^PRCA(430,+PRCABN,0)),"^",3)
.S PRCAMT=PRCAMT("O")+PRCAMT
.D BULL^IBCNSBL2(PRCABN,PRCAMT("O"),$$PAID^PRCAFN1(+PRCABN))
Q
;
DIE ;Edit AR Transaction
N DA,DIE,DR
S DR=PRCATEMP,DIE="^PRCA(433,",DA=PRCAEN D ^DIE
I '$D(PRCAMT) S PRCAD("DELETE")=1
Q
;
UPFY ;Update 433 FY multiple
Q:('$D(PRCAMT))!('$D(PRCAA2))
S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)=$P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)+PRCAMT,$P(^(0),U,4)=1
Q
;
EN1 ;Get Adj. No. Called from within 433 PRCA FY Input Templates
Q:'$D(PRCABN)
NEW X
F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1
Q
;
CHK ;Check for payment transactions or contractual adjustment
NEW DIR,X,Y
I $D(^PRCA(433,+$G(PRCAEN),8)),$P(^(8),"^",8) D Q
.S DIR("B")=$P($G(^PRCA(430.3,+PRCA("STATUS"),0)),"^"),DIR("A")="FINAL STATUS",DIR(0)="SOBX^CA:CANCELLATION;CO:COLLECTED/CLOSED"
.S DIR("?",1)="Enter either:"
.S DIR("?",2)=" 'CA' for 'CANCELLATION'"
.S DIR("?",3)=" 'CO' for 'COLLECTED/CLOSED'"
.S DIR("?",4)="These are the only selectable statuses."
.S DIR("?")="An up-arrow or <RETURN> will accept the default of 'CANCELLATION' because status is required."
.D ^DIR Q:Y="" I Y="CO" S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I ",2,7,20,"[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(433,X,1)),"^",2),0)),"^",3)_",") S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0)) Q
Q
;
UPFYRC ;Update 433
Q:('$D(PRCAMT))!('$D(PRCAA2))
S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)=$G(PRCAPBAL)+PRCAMT,$P(^(0),U,4)=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCADJ 2863 printed Dec 13, 2024@01:39:17 Page 2
PRCADJ ;SF-ISC/YJK,ALB/CMS - ADJUSTMENT TRANSACTION ;9/7/95 10:58 AM
+1 ;;4.5;Accounts Receivable;**21,67,48,89,63,111,123,131,134,169**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
+6 ;
UPPRIN ;Update Prin bal
+1 NEW DA,DIE,DR,X,Y
+2 if ('$DATA(PRCABN))!('$DATA(PRCAMT))
QUIT
+3 if '$DATA(^PRCA(430,+PRCABN,7))
QUIT
+4 SET PRCAMT("C")=$PIECE(^PRCA(430,+PRCABN,7),U,1)+PRCAMT
+5 SET DA=+PRCABN
SET DIE="^PRCA(430,"
SET DR="71////^S X="_PRCAMT("C")
DO ^DIE
+6 SET (X,PRCAMT("C"))=$GET(^PRCA(430,+PRCABN,7))
+7 IF ($PIECE($GET(^PRCA(430,+$GET(PRCABN),0)),"^",2)=$ORDER(^PRCA(430.2,"AC",33,0)))
IF ($PIECE($GET(^PRCA(430,+PRCABN,0)),U,8)'=$ORDER(^PRCA(430.3,"AC",112,0)))
QUIT
+8 IF $PIECE(X,"^",1)+$PIECE(X,"^",2)+$PIECE(X,"^",3)+$PIECE(X,"^",4)+$PIECE(X,"^",5)=0
Begin DoDot:1
+9 SET PRCA("SDT")=DT
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",111,0))
+10 DO CHK
DO UPSTATS^PRCAUT2
DO EOB
End DoDot:1
+11 SET RCREF=$PIECE($GET(^PRCA(430,+PRCABN,6)),U,5)
+12 IF RCREF]""
Begin DoDot:1
+13 SET RCREF=$SELECT(RCREF="DC":"RC",1:RCREF)
+14 SET DA=+PRCAEN
SET DIE="^PRCA(433,"
SET DR="7///^S X=RCREF"
DO ^DIE
End DoDot:1
+15 QUIT
+16 ;
EOB ;Another payer bulletin call
+1 IF ($PIECE($GET(^PRCA(433,+PRCAEN,8)),"^",8))
IF ($PIECE($GET(^PRCA(430.2,+$PIECE($GET(^PRCA(430,+PRCABN,0)),U,2),0)),U,6)="T")
Begin DoDot:1
+2 SET PRCAMT("O")=$PIECE($GET(^PRCA(430,+PRCABN,0)),"^",3)
+3 SET PRCAMT=PRCAMT("O")+PRCAMT
+4 DO BULL^IBCNSBL2(PRCABN,PRCAMT("O"),$$PAID^PRCAFN1(+PRCABN))
End DoDot:1
+5 QUIT
+6 ;
DIE ;Edit AR Transaction
+1 NEW DA,DIE,DR
+2 SET DR=PRCATEMP
SET DIE="^PRCA(433,"
SET DA=PRCAEN
DO ^DIE
+3 IF '$DATA(PRCAMT)
SET PRCAD("DELETE")=1
+4 QUIT
+5 ;
UPFY ;Update 433 FY multiple
+1 if ('$DATA(PRCAMT))!('$DATA(PRCAA2))
QUIT
+2 SET $PIECE(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
+3 SET $PIECE(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)=$PIECE(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)+PRCAMT
SET $PIECE(^(0),U,4)=1
+4 QUIT
+5 ;
EN1 ;Get Adj. No. Called from within 433 PRCA FY Input Templates
+1 if '$DATA(PRCABN)
QUIT
+2 NEW X
+3 FOR X=0:0
SET X=$ORDER(^PRCA(433,"C",PRCABN,X))
if 'X
QUIT
IF $PIECE($GET(^PRCA(433,X,1)),"^",4)
IF $PIECE(^(1),"^",2)=1!($PIECE(^(1),"^",2)=35)
SET PRCAQNM=$PIECE(^(1),"^",4)+1
+4 QUIT
+5 ;
CHK ;Check for payment transactions or contractual adjustment
+1 NEW DIR,X,Y
+2 IF $DATA(^PRCA(433,+$GET(PRCAEN),8))
IF $PIECE(^(8),"^",8)
Begin DoDot:1
+3 SET DIR("B")=$PIECE($GET(^PRCA(430.3,+PRCA("STATUS"),0)),"^")
SET DIR("A")="FINAL STATUS"
SET DIR(0)="SOBX^CA:CANCELLATION;CO:COLLECTED/CLOSED"
+4 SET DIR("?",1)="Enter either:"
+5 SET DIR("?",2)=" 'CA' for 'CANCELLATION'"
+6 SET DIR("?",3)=" 'CO' for 'COLLECTED/CLOSED'"
+7 SET DIR("?",4)="These are the only selectable statuses."
+8 SET DIR("?")="An up-arrow or <RETURN> will accept the default of 'CANCELLATION' because status is required."
+9 DO ^DIR
if Y=""
QUIT
IF Y="CO"
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",108,0))
End DoDot:1
QUIT
+10 FOR X=0:0
SET X=$ORDER(^PRCA(433,"C",PRCABN,X))
if 'X
QUIT
IF ",2,7,20,"[(","_$PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(433,X,1)),"^",2),0)),"^",3)_",")
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",108,0))
QUIT
+11 QUIT
+12 ;
UPFYRC ;Update 433
+1 if ('$DATA(PRCAMT))!('$DATA(PRCAA2))
QUIT
+2 SET $PIECE(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
+3 SET $PIECE(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)=$GET(PRCAPBAL)+PRCAMT
SET $PIECE(^(0),U,4)=1
+4 QUIT
