source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSEB1.m@ 1240

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

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1PRCSEB1 ;WISC/SAW,DGL-CONTROL POINT ACTIVITY EDITS CON'T; [7/21/98 3:35pm]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ENOD ;ENTER OBLIGATION DATA
5 W !,"This option is no longer in use." Q
6ENOD1 ;
7 W !,"Committed (Estimated) Cost: " I $D(^PRCS(410,DA,4)),$P(^(4),U)]"" W ?28,$J($P(^(4),U),0,2)
8 E W ?28,"None entered."
9 S DR="[PRCSENOD]",DIE=DIC D ^DIE S:'$D(PRCS) PRCS=DA Q:$D(PRCSOB) G EXIT
10ENCAD ;ENTER FMS DATA
11 D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0
12 S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select PURCHASE ORDER/OBLIGATION NO: ",D="D"
13 S DIC("S")="I +^(0),$D(^(3)),+^(3)=+$P(PRC(""CP""),"" ""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
14 S DA=+Y L +^PRCS(410,DA):15 G ENCAD:$T=0 S DIC(0)="AEMQ",DIE=DIC,DR="[PRCSENCAD]" D ^DIE L -^PRCS(410,DA) S T(1)="FMS (820)" D W3 G EXIT:%'=1 W !! G ENCAD
15ENA ;ENTER AN ADJUSTMENT
16 N AMOUNT,PO,REC,PODATE,SITE
17 D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
18 D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W L +^PRCS(410,DA):15 G ENA:$T=0 S $P(^PRCS(410,DA,0),U,2)="A"
19 D ADDADJ
20 S T(1)="Adjustment" K PRCS58 D W3 G EXIT:%'=1 W !! G ENA
21 ;
22 ;D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W L +^PRCS(410,DA):15 G ENA:$T=0 S $P(^PRCS(410,DA,0),U,2)="A"
23 ;
24ADDADJ S DIE="^PRCS(410,",DR="450////O;449////"_$P($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7) D ^DIE K DR
25ENA1 S DIC(0)="AEMQ",DIE=DIC,DR="24OBLIGATION NUMBER~R" D ^DIE K DR G CT:$D(Y)
26 S SITE=PRC("SITE"),$P(^PRCS(410,DA,7),"^")=DUZ
27 N PRCX442 S PRCX442=X,PRCX442=$$UPPER^PRCFFU5(PRCX442) D OBL^PRCSES2 S X=PRCX442
28 S DIC(0)="AEMQ",DIE="^PRCS(410,"
29ENA2 K DR S DR="[PRCSENA]" I $D(PRCS58) S DR="[PRCSENA 1358]"
30 D ^DIE G CT:$D(Y) I '$D(^PRCS(410,DA,4)) W $C(7),!,"You must enter an Adjustment $ Amount for this transaction.",! G ENA2
31 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>0 G ENA3
32 I $D(^PRCS(410,DA,4)) S X=$P(^(4),"^",6),X2=^(3),X1=$P(X2,"^",7)+$P(X2,"^",9) I $J(X,0,2)'=$J(X1,0,2) W $C(7),!,"Adjustment $ Amount does not equal the total of BOC $ Amounts.",!,"Please correct the error.",! G ENA2
33 S AMOUNT=$P($G(^PRCS(410,DA,4)),"^",6),$P(^PRCS(410,DA,4),"^",8)=AMOUNT
34ENA3 ;D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED
35 S PO=$P($G(^PRCS(410,DA,4)),"^",5) I PO'="",$D(^PRC(442,"C",PO)) S REC=$O(^PRC(442,"C",PO,0)),PODATE=$P($G(^PRC(442,+REC,1)),"^",15) S DR="23///^S X=PODATE",DIE="^PRCS(410," D ^DIE
36 L -^PRCS(410,DA)
37 QUIT
38ENFIS ;from fiscal's option
39 N PRC,AMOUNT,PO,REC,PODATE,SITE
40 N A,B,C,X,Y,Z
41 D SITE^PRCB0C G EXIT:'$G(PRC("SITE"))
42 D SUBSITE^PRCB0C G EXIT:'$G(PRC("SST"))&$D(^PRC(411,"UP",+PRC("SITE")))
43 D FY^PRCB0C G EXIT:PRC("FY")="^" D QTR^PRCB0C G EXIT:'$G(PRC("QTR"))
44 D FCP^PRCB0C G EXIT:'$G(PRC("CP")) D BBFY^PRCB0C G:'$G(PRC("BBFY")) EXIT
45 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
46 D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W L +^PRCS(410,DA):15 G ENFIS:$T=0 S $P(^PRCS(410,DA,0),U,2)="A"
47 S DIE="^PRCS(410,",DR="25.5//NO" D ^DIE K DR G CT:$D(Y)
48 D ADDADJ
49 S T(1)="Adjustment" K PRCS58 D W3 G EXIT:%'=1 W !! G ENFIS
50CT ;CANCEL AN ADJUSTMENT TRANSACTION
51 S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0 K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA)
52 K ZX I $D(^PRCS(410,DA,4)) S ZX=^(4),X=-$P(ZX,"^",8) D EBAL^PRCSEZ(PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_X,"C") I $P(ZX,"^",14)'="Y" D EBAL^PRCSEZ(PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_X,"O")
53 F I=1,3,6,8 S $P(ZX,"^",I)=0
54 I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
55 I $D(^PRCS(410,DA,12,0)) S N=0 F S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1)
56 W !!,"This adjustment has been cancelled." G EXIT
57ENC ;ENTER CEILING TRANSACTION
58 D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0) D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W L +^PRCS(410,DA):15 G ENC:$T=0 S DIC(0)="AEMQ",DIE=DIC,DR="[PRCSENC]" D ^DIE
59 L -^PRCS(410,DA) S T(1)="Ceiling" D W3 G EXIT:%'=1 W !! G ENC
60CPU ;ENTER/EDIT CONTROL POINT USERS
61 N PRCSSC S PRCSSC=0
62 D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S DA(1)=PRC("SITE"),DA=+PRC("CP")
63 I $D(PRCSC) S PRCSSC=PRCSC I '$D(^PRC(420,"A",DUZ,PRC("SITE"),+PRC("CP"),PRCSSC)) W !,"You cannot use this option for this control point." G EXIT
64CPU1 D EDIT^PRC0B(.X,"420;^PRC(420,;"_DA(1)_"~420.01;^PRC(420,"_DA(1)_",1,;"_DA,"12;6","L")
65 I X=-2 D EN^DDIOL("Fund control point is in use, try later.")
66 D TUSER(+$P(PRC("CP")," "))
67 Q
68TUSER(CP) ;Check for IFCAP terminated users
69 N A,XDA,ST,I,J
70 W !!,"Checking for IFCAP terminated users...",!
71 S XDA=0,ST=PRC("SITE"),I=0,J=0 F S XDA=$O(^PRC(420,ST,1,CP,1,XDA)) Q:XDA="" D
72 . S A=$G(^VA(200,XDA,0))
73 . I A="" D TUSER1 Q ;Dangling pointer removed
74 . I $D(^PRC(411,ST,8,XDA,0))#10=1 S I=I+1 D TUSER1 W !?5,$P(A,"^",1)," is deactivated and was removed as a Control Point User *"
75 . D NOW^%DTC
76 . I $P(A,"^",11)>0,$P(A,"^",11)<X S J=J+1 D TUSER1 W !?5,$P(A,"^",1)," is terminated and was removed as a Control Point User **"
77 W !!
78 I I>0 W "* CONTACT THE IFCAP APPLICATION COORDINATOR TO REACTIVATE THE USER" W:I>1 "S" W " *",!
79 I J>0 W "** CONTACT IRM TO REACTIVATE IN FILE 200 **",!
80 I J+I=0 W ?5,"None found",!
81 Q
82TUSER1 S DA=XDA,DA(1)=CP,DA(2)=ST,DIK="^PRC(420,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
83 Q
84SENDIT2 ;
85 N XX,XMDUZ,XMSUB,XMTEXT S XMDUZ="IFCAP PROCESSING",XX=$P($G(^PRCS(410,PRCHSY,7)),"^",1) S:XX="" XX=$P($G(^PRCS(410,PRCHSY,7)),"^",3)
86 S XMTEXT="PRCSAR(",XMSUB="SPLIT TRANSACTION NOTIFICATION",XMY(XX)=""
87 D ^XMD Q
88W W !!,"This transaction is assigned transaction number: ",X Q
89W1 W !!,"Sorry, you are not allowed to overcommit funds for control point ",$P(PRC("CP")," "),".",!,"Your current balance of $",PRCST1," is insufficient to cover the cost ($",PRCST,")",!,"of this request. Contact Fiscal Service.",$C(7) Q
90W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
91W3 W !!,"Would you like to enter another ",T(1)," transaction" S %=1 D YN^DICN G W3:%=0 Q
92EXIT K DA,DIC,DIE,DR,PRCS,PRCS58,PRCSL,T,X,X1,DLAYGO Q
Note: See TracBrowser for help on using the repository browser.