PRCBSTF ;WISC@ALTOONA/CLH-TRANSFER FUNDS TO ANOTHER FCP ; 05/01/94 10:40 AM
V ;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
GETTRAN ;GET TEMP TRANS NUMBER
S PRCF("X")="ABFS" D ^PRCFSITE Q:'%
D WAIT^PRCFYN S DIC="^PRCF(421.6,",DLAYGO=421.6,DIC(0)="XOLM",X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_($J#1000000000),PRCBT=0
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
S (TDA,DA)=+Y,PRCBT=1,PRCB("AMOUNT")="",PRCB("ANAMT")=""
S DIE=421.6,DR="[PRCB READER FILE EDIT]"
EDIT 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
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
I $D(X1) W !,"Not all required data has been entered. Re-edit transaction." G EDIT
S %A="Do you want to review this entry",%B="",%=1 D ^PRCFYN G:%<0 KILL D:%=1 DISP
QPOST ;GET FIRST SEQUENCE NUMBER FROM FILE 421
S %A="Are you ready to post this transaction",%B="",%=1 D ^PRCFYN G:%'=1 KILL
D WAIT^PRCFYN
D POST I $G(PRCQT) G GETTRAN
S DIK="^PRCF(421.6,",DA=TDA D ^DIK
S %A="Make another transfer",%B="",%=1 D ^PRCFYN G:%=1 GETTRAN
G OUT
POST ;post transfer
S PRCQT=""
SEQNUM1 D SEQNUM^PRCBE I '$D(X) S PRCQT=1 QUIT
S DIC="^PRCF(421,",DLAYGO=421,DIC(0)="LOX" D ^DIC I $P(Y,"^",3)'=1 G SEQNUM1
S SEQ1DA=+Y K DIC,DLAYGO
SEQNUM2 ;GET SECOND SEQUENCE NUMBER FROM FILE 421
D SEQNUM^PRCBE
S DIC="^PRCF(421,",DLAYGO=421,DIC(0)="LOX" D ^DIC I $P(Y,"^",3)'=1 G SEQNUM2
S SEQ2DA=+Y K DLAYGO,DIC
; Corrected SACC violation on locks for PRC*5*242
L +^PRCF(421,SEQ1DA):5 I '$T W !,$C(7),"Another user is editing this entry" K SEQ1DA Q
L +^PRCF(421,SEQ2DA):5 I '$T W !,$C(7),"Another user is editing this entry" K SEQ2DA L -^PRCF(421,SEQ1DA) Q
;
S TEMP=^PRCF(421,SEQ1DA,0)
S $P(TEMP,"^",2)=PRCB("FRCP"),$P(TEMP,"^",6)=PRCB("TDT"),$P(TEMP,"^",PRCB("QTR")+6)="-"_PRCB("AMOUNT"),$P(TEMP,"^",20)=0
S $P(TEMP,"^",22)=SEQ2DA
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)=""
I $G(TDA) S %X="^PRCF(421.6,TDA,1,",%Y="^PRCF(421,SEQ1DA,1," D %XY^%RCR
I $D(PRCDES) D
. N A,X,Y
. S A="421;^PRCF(421,;"_SEQ1DA_";17~421.01;^PRCF(421,"_SEQ1DA_",1,;"
. S X=PRCDES D ADD^PRC0B1(.X,.Y,A) K ^PRCF(421,SEQ1DA,1,"B")
. QUIT
S ^PRCF(421,SEQ1DA,0)=TEMP D EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ1DA,"1.6///"_PRC("BBFY"))
S TEMP2=^PRCF(421,SEQ2DA,0)
S $P(TEMP2,"^",2)=PRCB("TOCP"),$P(TEMP2,"^",6)=PRCB("TDT"),$P(TEMP2,"^",PRCB("QTR")+6)=PRCB("AMOUNT"),$P(TEMP2,"^",20)=0
S $P(TEMP2,"^",22)=SEQ1DA
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)=""
I $G(TDA) S %X="^PRCF(421.6,TDA,1,",%Y="^PRCF(421,SEQ2DA,1," D %XY^%RCR
I $D(PRCDES) D
. N A,X,Y
. S A="421;^PRCF(421,;"_SEQ2DA_";17~421.01;^PRCF(421,"_SEQ2DA_",1,;"
. S X=PRCDES D ADD^PRC0B1(.X,.Y,A) K ^PRCF(421,SEQ2DA,1,"B")
. QUIT
S ^PRCF(421,SEQ2DA,0)=TEMP2 D EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ2DA,"1.6///"_PRC("BBFY"))
L -^PRCF(421,SEQ1DA),-^PRCF(421,SEQ2DA)
W !!,"Finished. The following transactions have been created",!,"in file 421 (Fund Distribution):"
W !," ",$P(^PRCF(421,SEQ1DA,0),"^")
W !," ",$P(^PRCF(421,SEQ2DA,0),"^")
W !!
QUIT
;
OUT 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
K PRCBT,PRCB("TDT"),PRCB("ANAMT"),PRCB("LAST"),PRCB("MDIV"),PRCB("RNR")
Q
KILL S %A="Then I will delete this entry",%A(1)="Are you sure you want this deleted",%B="",%=1 D ^PRCFYN G:%'=1 QPOST
S DIK="^PRCF(421.6,",DA=TDA D ^DIK S X=" <Entry Deleted>*" D MSG^PRCFQ G OUT
DISP S IOP=ION,DIC="^PRCF(421.6,",(TO,FR)=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_($J#1000000000),L=0,BY=".01",FLDS="[PRCB READER DISP]" D EN1^DIP
S %A="Do you want to edit this entry",%B="",%=2 D ^PRCFYN Q:%'=1
S DIE="^PRCF(421.6,",DR="[PRCB READER FILE EDIT]",DA=TDA D ^DIE K DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBSTF 4320 printed Oct 16, 2024@18:01:39 Page 2
PRCBSTF ;WISC@ALTOONA/CLH-TRANSFER FUNDS TO ANOTHER FCP ; 05/01/94 10:40 AM
V ;;5.1;IFCAP;**143**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
GETTRAN ;GET TEMP TRANS NUMBER
+1 SET PRCF("X")="ABFS"
DO ^PRCFSITE
if '%
QUIT
+2 DO WAIT^PRCFYN
SET DIC="^PRCF(421.6,"
SET DLAYGO=421.6
SET DIC(0)="XOLM"
SET X=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_($JOB#1000000000)
SET PRCBT=0
+3 if '$DATA(COUNT)
SET COUNT=0
DO ^DIC
KILL DIC
if +Y<0
QUIT
IF $PIECE(Y,"^",3)=""
SET COUNT=COUNT+1
if COUNT>3
QUIT
SET DIK="^PRCF(421.6,"
SET DA=+Y
DO ^DIK
KILL DIK
GOTO GETTRAN
+4 SET (TDA,DA)=+Y
SET PRCBT=1
SET PRCB("AMOUNT")=""
SET PRCB("ANAMT")=""
+5 SET DIE=421.6
SET DR="[PRCB READER FILE EDIT]"
EDIT DO ^DIE
IF $DATA(Y)
SET %A="Do you want to quit and delete this entry"
SET %B=""
SET %=1
DO ^PRCFYN
if %=2
GOTO EDIT
SET DIK="^PRCF(421.6,"
DO ^DIK
GOTO OUT
+1 KILL X,X1
SET X=$PIECE(^PRCF(421.6,TDA,0),"^",2,9)
FOR I=1:1:8
IF $PIECE(X,"^",I)=""
SET X1=1
+2 IF $DATA(X1)
WRITE !,"Not all required data has been entered. Re-edit transaction."
GOTO EDIT
+3 SET %A="Do you want to review this entry"
SET %B=""
SET %=1
DO ^PRCFYN
if %<0
GOTO KILL
if %=1
DO DISP
QPOST ;GET FIRST SEQUENCE NUMBER FROM FILE 421
+1 SET %A="Are you ready to post this transaction"
SET %B=""
SET %=1
DO ^PRCFYN
if %'=1
GOTO KILL
+2 DO WAIT^PRCFYN
+3 DO POST
IF $GET(PRCQT)
GOTO GETTRAN
+4 SET DIK="^PRCF(421.6,"
SET DA=TDA
DO ^DIK
+5 SET %A="Make another transfer"
SET %B=""
SET %=1
DO ^PRCFYN
if %=1
GOTO GETTRAN
+6 GOTO OUT
POST ;post transfer
+1 SET PRCQT=""
SEQNUM1 DO SEQNUM^PRCBE
IF '$DATA(X)
SET PRCQT=1
QUIT
+1 SET DIC="^PRCF(421,"
SET DLAYGO=421
SET DIC(0)="LOX"
DO ^DIC
IF $PIECE(Y,"^",3)'=1
GOTO SEQNUM1
+2 SET SEQ1DA=+Y
KILL DIC,DLAYGO
SEQNUM2 ;GET SECOND SEQUENCE NUMBER FROM FILE 421
+1 DO SEQNUM^PRCBE
+2 SET DIC="^PRCF(421,"
SET DLAYGO=421
SET DIC(0)="LOX"
DO ^DIC
IF $PIECE(Y,"^",3)'=1
GOTO SEQNUM2
+3 SET SEQ2DA=+Y
KILL DLAYGO,DIC
+4 ; Corrected SACC violation on locks for PRC*5*242
+5 LOCK +^PRCF(421,SEQ1DA):5
IF '$TEST
WRITE !,$CHAR(7),"Another user is editing this entry"
KILL SEQ1DA
QUIT
+6 LOCK +^PRCF(421,SEQ2DA):5
IF '$TEST
WRITE !,$CHAR(7),"Another user is editing this entry"
KILL SEQ2DA
LOCK -^PRCF(421,SEQ1DA)
QUIT
+7 ;
+8 SET TEMP=^PRCF(421,SEQ1DA,0)
+9 SET $PIECE(TEMP,"^",2)=PRCB("FRCP")
SET $PIECE(TEMP,"^",6)=PRCB("TDT")
SET $PIECE(TEMP,"^",PRCB("QTR")+6)="-"_PRCB("AMOUNT")
SET $PIECE(TEMP,"^",20)=0
+10 SET $PIECE(TEMP,"^",22)=SEQ2DA
+11 SET $PIECE(^PRCF(421,SEQ1DA,4),"^",PRCB("QTR"))=0
SET $PIECE(^(4),"^",5,6)=-PRCB("ANAMT")_"^"_PRCB("RNR")
SET ^PRCF(421,"AL",PRCF("SIFY"),0,SEQ1DA)=""
SET ^PRCF(421,"AC",PRCF("SIFY")_"-"_+PRCB("FRCP"),SEQ1DA)=""
+12 IF $GET(TDA)
SET %X="^PRCF(421.6,TDA,1,"
SET %Y="^PRCF(421,SEQ1DA,1,"
DO %XY^%RCR
+13 IF $DATA(PRCDES)
Begin DoDot:1
+14 NEW A,X,Y
+15 SET A="421;^PRCF(421,;"_SEQ1DA_";17~421.01;^PRCF(421,"_SEQ1DA_",1,;"
+16 SET X=PRCDES
DO ADD^PRC0B1(.X,.Y,A)
KILL ^PRCF(421,SEQ1DA,1,"B")
+17 QUIT
End DoDot:1
+18 SET ^PRCF(421,SEQ1DA,0)=TEMP
DO EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ1DA,"1.6///"_PRC("BBFY"))
+19 SET TEMP2=^PRCF(421,SEQ2DA,0)
+20 SET $PIECE(TEMP2,"^",2)=PRCB("TOCP")
SET $PIECE(TEMP2,"^",6)=PRCB("TDT")
SET $PIECE(TEMP2,"^",PRCB("QTR")+6)=PRCB("AMOUNT")
SET $PIECE(TEMP2,"^",20)=0
+21 SET $PIECE(TEMP2,"^",22)=SEQ1DA
+22 SET $PIECE(^PRCF(421,SEQ2DA,4),"^",PRCB("QTR"))=0
SET $PIECE(^(4),"^",5,6)=PRCB("ANAMT")_"^"_PRCB("RNR")
SET ^PRCF(421,"AL",PRCF("SIFY"),0,SEQ2DA)=""
SET ^PRCF(421,"AC",PRCF("SIFY")_"-"_+PRCB("TOCP"),SEQ2DA)=""
+23 IF $GET(TDA)
SET %X="^PRCF(421.6,TDA,1,"
SET %Y="^PRCF(421,SEQ2DA,1,"
DO %XY^%RCR
+24 IF $DATA(PRCDES)
Begin DoDot:1
+25 NEW A,X,Y
+26 SET A="421;^PRCF(421,;"_SEQ2DA_";17~421.01;^PRCF(421,"_SEQ2DA_",1,;"
+27 SET X=PRCDES
DO ADD^PRC0B1(.X,.Y,A)
KILL ^PRCF(421,SEQ2DA,1,"B")
+28 QUIT
End DoDot:1
+29 SET ^PRCF(421,SEQ2DA,0)=TEMP2
DO EDIT^PRC0B(.X,"421;^PRCF(421,;"_SEQ2DA,"1.6///"_PRC("BBFY"))
+30 LOCK -^PRCF(421,SEQ1DA),-^PRCF(421,SEQ2DA)
+31 WRITE !!,"Finished. The following transactions have been created",!,"in file 421 (Fund Distribution):"
+32 WRITE !," ",$PIECE(^PRCF(421,SEQ1DA,0),"^")
+33 WRITE !," ",$PIECE(^PRCF(421,SEQ2DA,0),"^")
+34 WRITE !!
+35 QUIT
+36 ;
OUT KILL %F,COUNT,D0,DA,DIC,DIE,DIK,DR,PRCB("AMOUNT"),PRCB("FRCP"),PRCB("QTR"),PRCB("TOCP"),PRCB("TRANS"),SEQ1DA,SEQ2DA,TDA,TEMP,TEMP2,ZX
+1 KILL PRCBT,PRCB("TDT"),PRCB("ANAMT"),PRCB("LAST"),PRCB("MDIV"),PRCB("RNR")
+2 QUIT
KILL SET %A="Then I will delete this entry"
SET %A(1)="Are you sure you want this deleted"
SET %B=""
SET %=1
DO ^PRCFYN
if %'=1
GOTO QPOST
+1 SET DIK="^PRCF(421.6,"
SET DA=TDA
DO ^DIK
SET X=" <Entry Deleted>*"
DO MSG^PRCFQ
GOTO OUT
DISP SET IOP=ION
SET DIC="^PRCF(421.6,"
SET (TO,FR)=PRC("SITE")_"-"_^%ZOSF("VOL")_"-"_($JOB#1000000000)
SET L=0
SET BY=".01"
SET FLDS="[PRCB READER DISP]"
DO EN1^DIP
+1 SET %A="Do you want to edit this entry"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=1
QUIT
+2 SET DIE="^PRCF(421.6,"
SET DR="[PRCB READER FILE EDIT]"
SET DA=TDA
DO ^DIE
KILL DIE
+3 QUIT
