source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCBSTF.m@ 1638

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1PRCBSTF ;WISC@ALTOONA/CLH-TRANSFER FUNDS TO ANOTHER FCP ; 05/01/94 10:40 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4GETTRAN ;GET TEMP TRANS NUMBER
5 S PRCF("X")="ABFS" D ^PRCFSITE Q:'%
6 D WAIT^PRCFYN S DIC="^PRCF(421.6,",DLAYGO=421.6,DIC(0)="XOLM",X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_($J#1000000000),PRCBT=0
7 S:'$D(COUNT) COUNT=0 D ^DIC K DIC Q:+Y<0 I $P(Y,"^",3)="" S COUNT=COUNT+1 Q:COUNT>3 S DIK="^PRCF(421.6,",DA=+Y D ^DIK K DIK G GETTRAN
8 S (TDA,DA)=+Y,PRCBT=1,PRCB("AMOUNT")="",PRCB("ANAMT")=""
9 S DIE=421.6,DR="[PRCB READER FILE EDIT]"
10EDIT D ^DIE I $D(Y) S %A="Do you want to quit and delete this entry",%B="",%=1 D ^PRCFYN G:%=2 EDIT S DIK="^PRCF(421.6," D ^DIK G OUT
11 K X,X1 S X=$P(^PRCF(421.6,TDA,0),"^",2,9) F I=1:1:8 I $P(X,"^",I)="" S X1=1
12 I $D(X1) W !,"Not all required data has been entered. Re-edit transaction." G EDIT
13 S %A="Do you want to review this entry",%B="",%=1 D ^PRCFYN G:%<0 KILL D:%=1 DISP
14QPOST ;GET FIRST SEQUENCE NUMBER FROM FILE 421
15 S %A="Are you ready to post this transaction",%B="",%=1 D ^PRCFYN G:%'=1 KILL
16 D WAIT^PRCFYN
17 D POST I $G(PRCQT) G GETTRAN
18 S DIK="^PRCF(421.6,",DA=TDA D ^DIK
19 S %A="Make another transfer",%B="",%=1 D ^PRCFYN G:%=1 GETTRAN
20 G OUT
21POST ;post transfer
22 S PRCQT=""
23SEQNUM1 D SEQNUM^PRCBE I '$D(X) S PRCQT=1 QUIT
24 S DIC="^PRCF(421,",DLAYGO=421,DIC(0)="LOX" D ^DIC I $P(Y,"^",3)'=1 G SEQNUM1
25 S SEQ1DA=+Y K DIC,DLAYGO
26SEQNUM2 ;GET SECOND SEQUENCE NUMBER FROM FILE 421
27 D SEQNUM^PRCBE
28 S DIC="^PRCF(421,",DLAYGO=421,DIC(0)="LOX" D ^DIC I $P(Y,"^",3)'=1 G SEQNUM2
29 S SEQ2DA=+Y K DLAYGO,DIC
30 ; Corrected SACC violation on locks for PRC*5*242
31 L +^PRCF(421,SEQ1DA):5 I '$T W !,$C(7),"Another user is editing this entry" K SEQ1DA Q
32 L +^PRCF(421,SEQ2DA):5 I '$T W !,$C(7),"Another user is editing this entry" K SEQ2DA L -^PRCF(421,SEQ1DA) Q
33 ;
34 S TEMP=^PRCF(421,SEQ1DA,0)
35 S $P(TEMP,"^",2)=PRCB("FRCP"),$P(TEMP,"^",6)=PRCB("TDT"),$P(TEMP,"^",PRCB("QTR")+6)="-"_PRCB("AMOUNT"),$P(TEMP,"^",20)=0
36 S $P(TEMP,"^",22)=SEQ2DA
37 S $P(^PRCF(421,SEQ1DA,4),"^",PRCB("QTR"))=0,$P(^(4),"^",5,6)=-PRCB("ANAMT")_"^"_PRCB("RNR"),^PRCF(421,"AL",PRCF("SIFY"),0,SEQ1DA)="",^PRCF(421,"AC",PRCF("SIFY")_"-"_+PRCB("FRCP"),SEQ1DA)=""
38 I $G(TDA) S %X="^PRCF(421.6,TDA,1,",%Y="^PRCF(421,SEQ1DA,1," D %XY^%RCR
39 I $D(PRCDES) D
40 . N A,X,Y
41 . S A="421;^PRCF(421,;"_SEQ1DA_";17~421.01;^PRCF(421,"_SEQ1DA_",1,;"
42 . S X=PRCDES D ADD^PRC0B1(.X,.Y,A) K ^PRCF(421,SEQ1DA,1,"B")
43 . QUIT
44 S ^PRCF(421,SEQ1DA,0)=TEMP D EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ1DA,"1.6///"_PRC("BBFY"))
45 S TEMP2=^PRCF(421,SEQ2DA,0)
46 S $P(TEMP2,"^",2)=PRCB("TOCP"),$P(TEMP2,"^",6)=PRCB("TDT"),$P(TEMP2,"^",PRCB("QTR")+6)=PRCB("AMOUNT"),$P(TEMP2,"^",20)=0
47 S $P(TEMP2,"^",22)=SEQ1DA
48 S $P(^PRCF(421,SEQ2DA,4),"^",PRCB("QTR"))=0,$P(^(4),"^",5,6)=PRCB("ANAMT")_"^"_PRCB("RNR"),^PRCF(421,"AL",PRCF("SIFY"),0,SEQ2DA)="",^PRCF(421,"AC",PRCF("SIFY")_"-"_+PRCB("TOCP"),SEQ2DA)=""
49 I $G(TDA) S %X="^PRCF(421.6,TDA,1,",%Y="^PRCF(421,SEQ2DA,1," D %XY^%RCR
50 I $D(PRCDES) D
51 . N A,X,Y
52 . S A="421;^PRCF(421,;"_SEQ2DA_";17~421.01;^PRCF(421,"_SEQ2DA_",1,;"
53 . S X=PRCDES D ADD^PRC0B1(.X,.Y,A) K ^PRCF(421,SEQ2DA,1,"B")
54 . QUIT
55 S ^PRCF(421,SEQ2DA,0)=TEMP2 D EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ2DA,"1.6///"_PRC("BBFY"))
56 L -^PRCF(421,SEQ1DA),-^PRCF(421,SEQ2DA)
57 W !!,"Finished. The following transactions have been created",!,"in file 421 (Fund Distribution):"
58 W !," ",$P(^PRCF(421,SEQ1DA,0),"^")
59 W !," ",$P(^PRCF(421,SEQ2DA,0),"^")
60 W !!
61 QUIT
62 ;
63OUT K %F,COUNT,D0,DA,DIC,DIE,DIK,DR,PRCB("AMOUNT"),PRCB("FRCP"),PRCB("QTR"),PRCB("TOCP"),PRCB("TRANS"),SEQ1DA,SEQ2DA,TDA,TEMP,TEMP2,ZX
64 K PRCBT,PRCB("TDT"),PRCB("ANAMT"),PRCB("LAST"),PRCB("MDIV"),PRCB("RNR")
65 Q
66KILL S %A="Then I will delete this entry",%A(1)="Are you sure you want this deleted",%B="",%=1 D ^PRCFYN G:%'=1 QPOST
67 S DIK="^PRCF(421.6,",DA=TDA D ^DIK S X=" <Entry Deleted>*" D MSG^PRCFQ G OUT
68DISP S IOP=ION,DIC="^PRCF(421.6,",(TO,FR)=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_$J,L=0,BY=".01",FLDS="[PRCB READER DISP]" D EN1^DIP
69 S %A="Do you want to edit this entry",%B="",%=2 D ^PRCFYN Q:%'=1
70 S DIE="^PRCF(421.6,",DR="[PRCB READER FILE EDIT]",DA=TDA D ^DIE K DIE
71 Q
Note: See TracBrowser for help on using the repository browser.