source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAWO1.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1PRCAWO1 ;SF-ISC/YJK-ADMIN.COST CHARGE,TRANSACTION SUBROUTINES ;7/9/93 12:18 PM
2V ;;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 ;
7EN1 ;Administrative cost charge
8 D BEGIN^PRCAWO G:('$D(PRCAEN))!('$D(PRCABN)) END1 D DIEEN,KILLV G EN1
9DIEEN 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
26UPD 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
31KILLV ;
32END1 K PRCA,PRCADM,PRCAOK,%,PRCACC,PRCAMF,PRCA1,PRCA2,PRCAEN,PRCABN,PRCATYPE,PRCATY Q
33 ;
34MSG W !!,*7,"INVALID AMOUNTS ENTERED."
35 S PRCA("EXIT")="" Q
36DIP K DXS S D0=PRCAEN D ^PRCATO3 K DXS Q
37ASK1 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
40ASK2 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.
45DIE1 ;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 ;
49TRANST Q:'$D(PRCAEN) S $P(^PRCA(433,PRCAEN,0),U,4)=2 Q
50 ;========================SUBROUTINE DELETE============================
51DELETE ;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================================
84LOCKF 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
86END K PRCA,PRCABN,PRCAEN,PRCAPREV,PRCATYPE,DIE,DIC,PRCAMF,PRCACC,A Q
Note: See TracBrowser for help on using the repository browser.