Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCADJ

PRCADJ.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. ;
  1. UPPRIN ;Update Prin bal
  1. N DA,DIE,DR,X,Y
  1. Q:('$D(PRCABN))!('$D(PRCAMT))
  1. Q:'$D(^PRCA(430,+PRCABN,7))
  1. S PRCAMT("C")=$P(^PRCA(430,+PRCABN,7),U,1)+PRCAMT
  1. S DA=+PRCABN,DIE="^PRCA(430,",DR="71////^S X="_PRCAMT("C") D ^DIE
  1. S (X,PRCAMT("C"))=$G(^PRCA(430,+PRCABN,7))
  1. 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
  1. I $P(X,"^",1)+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)=0 D
  1. .S PRCA("SDT")=DT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",111,0))
  1. .D CHK,UPSTATS^PRCAUT2,EOB
  1. S RCREF=$P($G(^PRCA(430,+PRCABN,6)),U,5)
  1. I RCREF]"" D
  1. .S RCREF=$S(RCREF="DC":"RC",1:RCREF)
  1. .S DA=+PRCAEN,DIE="^PRCA(433,",DR="7///^S X=RCREF" D ^DIE
  1. Q
  1. ;
  1. EOB ;Another payer bulletin call
  1. 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
  1. .S PRCAMT("O")=$P($G(^PRCA(430,+PRCABN,0)),"^",3)
  1. .S PRCAMT=PRCAMT("O")+PRCAMT
  1. .D BULL^IBCNSBL2(PRCABN,PRCAMT("O"),$$PAID^PRCAFN1(+PRCABN))
  1. Q
  1. ;
  1. DIE ;Edit AR Transaction
  1. N DA,DIE,DR
  1. S DR=PRCATEMP,DIE="^PRCA(433,",DA=PRCAEN D ^DIE
  1. I '$D(PRCAMT) S PRCAD("DELETE")=1
  1. Q
  1. ;
  1. UPFY ;Update 433 FY multiple
  1. Q:('$D(PRCAMT))!('$D(PRCAA2))
  1. S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
  1. 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
  1. Q
  1. ;
  1. EN1 ;Get Adj. No. Called from within 433 PRCA FY Input Templates
  1. Q:'$D(PRCABN)
  1. NEW X
  1. 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
  1. Q
  1. ;
  1. CHK ;Check for payment transactions or contractual adjustment
  1. NEW DIR,X,Y
  1. I $D(^PRCA(433,+$G(PRCAEN),8)),$P(^(8),"^",8) D Q
  1. .S DIR("B")=$P($G(^PRCA(430.3,+PRCA("STATUS"),0)),"^"),DIR("A")="FINAL STATUS",DIR(0)="SOBX^CA:CANCELLATION;CO:COLLECTED/CLOSED"
  1. .S DIR("?",1)="Enter either:"
  1. .S DIR("?",2)=" 'CA' for 'CANCELLATION'"
  1. .S DIR("?",3)=" 'CO' for 'COLLECTED/CLOSED'"
  1. .S DIR("?",4)="These are the only selectable statuses."
  1. .S DIR("?")="An up-arrow or <RETURN> will accept the default of 'CANCELLATION' because status is required."
  1. .D ^DIR Q:Y="" I Y="CO" S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
  1. 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
  1. Q
  1. ;
  1. UPFYRC ;Update 433
  1. Q:('$D(PRCAMT))!('$D(PRCAA2))
  1. S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,5)=PRCAMT
  1. S $P(^PRCA(433,PRCAEN,4,PRCAA2,0),U,2)=$G(PRCAPBAL)+PRCAMT,$P(^(0),U,4)=1
  1. Q