- 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 Feb 18, 2025@23:05:41 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