| 1 | PRCAWO1 ;SF-ISC/YJK-ADMIN.COST CHARGE,TRANSACTION SUBROUTINES ;7/9/93 12:18 PM
|
|---|
| 2 | V ;;4.5;Accounts Receivable;**67,68,153**;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;Administrative cost charge transaction
|
|---|
| 5 | ; and subroutines called by ^PRCAWO.
|
|---|
| 6 | ;
|
|---|
| 7 | EN1 ;Administrative cost charge
|
|---|
| 8 | D BEGIN^PRCAWO G:('$D(PRCAEN))!('$D(PRCABN)) END1 D DIEEN,KILLV G EN1
|
|---|
| 9 | DIEEN S DIC="^PRCA(433,",DIE=DIC,DR="[PRCAE ADMIN]",DA=PRCAEN
|
|---|
| 10 | S DIC=DIE,PRCA("LOCK")=0 D LOCKF Q:PRCA("LOCK")=1 D ^DIE
|
|---|
| 11 | I '$D(^PRCA(433,PRCAEN,2)) D DELETE Q
|
|---|
| 12 | S PRCADM=+$P(^PRCA(433,PRCAEN,2),U,1)+$P(^(2),U,2)+$P(^(2),U,3)+$P(^(2),U,4)+$P(^(2),U,8)+$P(^(2),U,9),$P(^PRCA(433,PRCAEN,1),U,5)=PRCADM+$P(^(2),U,5)+$P(^(2),U,6)+$P(^(2),U,7)
|
|---|
| 13 | D DIP S PRCAOK=0 D ASK1 I $D(PRCA("EXIT")) D DELETE Q
|
|---|
| 14 | I $D(PRCASUP),PRCAOK=1,$G(^PRCA(433,PRCAEN,2))["-" D I $D(PRCA("EXIT")) D DELETE Q
|
|---|
| 15 | .N ND2,ND7,I,J,K
|
|---|
| 16 | .S ND2=$G(^PRCA(433,PRCAEN,2)),ND7=$G(^PRCA(430,PRCABN,7))
|
|---|
| 17 | .I PRCADM<0,-PRCADM>$P(ND7,U,3) D MSG Q
|
|---|
| 18 | .F I=5:1:7 I $P(ND2,U,I)<0 D I $D(PRCA("EXIT")) Q
|
|---|
| 19 | ..S J=$P(ND2,U,I)
|
|---|
| 20 | ..S K=$S(I=5:4,I=6:5,1:2)
|
|---|
| 21 | ..I -J>$P(ND7,U,K) D MSG
|
|---|
| 22 | ..Q
|
|---|
| 23 | .Q
|
|---|
| 24 | I PRCAOK=1 D UPD W ?40,"*** DONE***",! Q
|
|---|
| 25 | D ASK2 G:PRCAOK=1 DIEEN D DELETE Q
|
|---|
| 26 | UPD S PRCAMF=$S($P(^PRCA(433,PRCAEN,2),U,5)]"":+$P(^(2),U,5),1:0),$P(^PRCA(430,PRCABN,7),U,4)=PRCAMF+$P(^PRCA(430,PRCABN,7),U,4)
|
|---|
| 27 | S PRCACC=$S(+$P(^PRCA(433,PRCAEN,2),U,6)]"":+$P(^(2),U,6),1:0),$P(^PRCA(430,PRCABN,7),U,5)=PRCACC+$P(^PRCA(430,PRCABN,7),U,5)
|
|---|
| 28 | S $P(^PRCA(430,PRCABN,7),U,3)=+PRCADM+$P(^PRCA(430,PRCABN,7),U,3)
|
|---|
| 29 | S $P(^PRCA(430,PRCABN,7),U,2)=+$P(^PRCA(433,PRCAEN,2),U,7)+$P(^PRCA(430,PRCABN,7),U,2)
|
|---|
| 30 | D TRANST
|
|---|
| 31 | KILLV ;
|
|---|
| 32 | END1 K PRCA,PRCADM,PRCAOK,%,PRCACC,PRCAMF,PRCA1,PRCA2,PRCAEN,PRCABN,PRCATYPE,PRCATY Q
|
|---|
| 33 | ;
|
|---|
| 34 | MSG W !!,*7,"INVALID AMOUNTS ENTERED."
|
|---|
| 35 | S PRCA("EXIT")="" Q
|
|---|
| 36 | DIP K DXS S D0=PRCAEN D ^PRCATO3 K DXS Q
|
|---|
| 37 | ASK1 S %=2 W !!,"Is this correct" D YN^DICN I %<0 S PRCA("EXIT")="" Q
|
|---|
| 38 | I %=0 W !,"Answer 'Y' or 'YES' if the data is correct, answer 'N' or 'NO' if not",! G ASK1
|
|---|
| 39 | S:%=1 PRCAOK=1 Q
|
|---|
| 40 | ASK2 S %=2 W !!,"Do you want to edit" D YN^DICN I %<0 S PRCA("EXIT")="" Q
|
|---|
| 41 | I %=0 W !,"Answer 'Y' or 'YES' if you want to edit the data, answer 'N' or 'NO' if you do not want to edit the data",! G ASK2
|
|---|
| 42 | S:%=1 PRCAOK=1 Q
|
|---|
| 43 | ;======================SUBROUTINE DIE=============================
|
|---|
| 44 | ;this is called by ^PRCAWO.
|
|---|
| 45 | DIE1 ;update the current status in the file 430.
|
|---|
| 46 | S DIE="^PRCA(430,",DA=PRCABN,DR="8///"_PRCA("STATUS")_";" D ^DIE
|
|---|
| 47 | K DIC,DA,DR Q ;end of DIE1
|
|---|
| 48 | ;
|
|---|
| 49 | TRANST Q:'$D(PRCAEN) S $P(^PRCA(433,PRCAEN,0),U,4)=2 Q
|
|---|
| 50 | ;========================SUBROUTINE DELETE============================
|
|---|
| 51 | DELETE ;Deletes an entry but leaves an audit trail
|
|---|
| 52 | ; Requires PRCABN=Bill #
|
|---|
| 53 | ; PRCAEN=Transaction to Delete
|
|---|
| 54 | ; PRCAARC=True if archiving this trans
|
|---|
| 55 | ; PRCANOPR=True if no message should be printed to screen
|
|---|
| 56 | ; PRCACOMM=Reason why this transaction is being deleted
|
|---|
| 57 | ; PRCAMAN=True if IRM is manually calling this API
|
|---|
| 58 | NEW X,DINUM,DD,DIC,DLAYGO,DO,DIK,DIE,DA,T0,T5,FLAG
|
|---|
| 59 | S FLAG=0
|
|---|
| 60 | ;Check for previous audit trail
|
|---|
| 61 | S T0=$G(^PRCA(433,PRCAEN,0)),T5=$G(^PRCA(433,PRCAEN,5)) I 'T0 Q
|
|---|
| 62 | I $P(T0,U,4)=1,$P(T0,U,10)=1,($P(T5,U,2)["SYSTEM INACTIVATED"!($P(T5,U,2)["SYSTEM ARCHIVED")) S FLAG=1 D
|
|---|
| 63 | .I $G(PRCAMAN) W !,"You are attempting to delete a record that already appears to have been deleted and contains an audit trail. Delete failed!"
|
|---|
| 64 | I FLAG Q
|
|---|
| 65 | S PRCATYPE=$P($G(^PRCA(433,PRCAEN,1)),U,2)
|
|---|
| 66 | S:'$D(PRCACOMM) PRCACOMM="USER CANCELED"
|
|---|
| 67 | S:'$D(PRCABN) PRCABN=$P($G(^PRCA(433,PRCAEN,0)),U,2)
|
|---|
| 68 | S DIK="^PRCA(433,",DA=PRCAEN D ^DIK K DIK
|
|---|
| 69 | ;
|
|---|
| 70 | ; Now Create the stub full of audit trails...
|
|---|
| 71 | ; Trans#(.01), Trans Status(4), Brief Comment(5.02), Comments(41),
|
|---|
| 72 | ; Inc. Trans Flag(10), Trans Date(11), Trans Type(12), Proc. By(42)
|
|---|
| 73 | S (X,DINUM)=PRCAEN,DIC="^PRCA(433,",DIC(0)="L",DLAYGO=433
|
|---|
| 74 | K DD,DO D FILE^DICN K DIC,DLAYGO,DO
|
|---|
| 75 | ;
|
|---|
| 76 | ; Ensure the 'last transaction' counter is accurate
|
|---|
| 77 | S $P(^PRCA(433,0),U,3)=$O(^PRCA(433,"A"),-1)
|
|---|
| 78 | ;
|
|---|
| 79 | S DIE="^PRCA(433,",DR="[PRCA CREATE TRANS STUB]",DA=PRCAEN D ^DIE
|
|---|
| 80 | W:'$G(PRCANOPR) !,*7," NOTHING CHANGED !",!!
|
|---|
| 81 | S PRCAD("DELETE")="" K PRCANOPR,%,%DT,%X,%Y
|
|---|
| 82 | Q
|
|---|
| 83 | ;======================SUBROUTINE LOCKF================================
|
|---|
| 84 | LOCKF L @("+"_DIC_DA_"):1") I '$T W !,*7,"ANOTHER USER IS EDITING THIS ENTRY , TRY LATER.",! S PRCA("LOCK")=1
|
|---|
| 85 | Q ;end of LOCKF
|
|---|
| 86 | END K PRCA,PRCABN,PRCAEN,PRCAPREV,PRCATYPE,DIE,DIC,PRCAMF,PRCACC,A Q
|
|---|
