source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSUT2.m@ 1087

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1PRCSUT2 ;WISC/SAW/CTB/DXH - TRANSACTION UTILITY ; 3/16/00 3:16pm
2V ;;5.1;IFCAP;**13**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; assigns a permanent transaction number to an existing transaction
5 ; if the existing transaction is temporary, it is converted to
6 ; permanent.
7 ; if the existing transaction is permanent, a new ien is created and
8 ; populated with info from the existing transaction, then canceled.
9 ; The original transaction is updated with the new transaction number.
10ANTN ;
11 N ODA,PNW,TX1,T1,T2,T3,T4,T5,PRCSY,PRCSDIC,PRCSAPP
12ANTN1 D EN3^PRCSUT ; ask site, CP
13 G W5:'$D(PRC("SITE"))
14 G EXIT:Y<0
15 W !!,"Select the existing transaction number to be replaced",!
16 S DIC="^PRCS(410,",DIC(0)="AEFMQ"
17 S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
18 D ^PRCSDIC G:Y<0 EXIT
19 S (ODA,DA,T1)=+Y,PRCSDIC=DIC
20 L +^PRCS(410,DA):1
21 I $T=0 W !,"File being accessed...please try later" G ANTN1
22 D REVIEW
23 S T2=^PRCS(410,DA,0) ; node 0 string of txn to be replaced
24 S T5=$P(T2,"^",10) ; substation
25 S T4=$P(T2,"^",2) ; txn type of transaction to be replaced
26 S T2=$P(T2,"^") ; txn number to be replaced
27 S T3=$P(^PRCS(410,DA,3),"^") ; control point of txn to be replaced
28 K DA,DIC,Y
29 W !!,"Enter the information for the new transaction number",!
30 D EN^PRCSUT3 ; ask SITE, FY, QRTR, CP for new txn
31 G:'$D(PRC("QTR"))!('$D(PRC("CP"))) EXIT
32 S TX1=X
33 D IP^PRCSUT ; set up prcsip
34 S PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)
35 I PRC("CP")'=T3,PRCSAPP["_" D PRCFY G EXIT:PRCSAPP["_"
36 S X=TX1
37 D EN1^PRCSUT3 ; generate new name for txn and put in X
38 G:'X EXIT
39 S TX1=X,(DIC,DIE)="^PRCS(410,"
40CK G:'+T2 CK1 ; don't set up new ien for temp txns (txns with non-numeric names)
41 K DA
42 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ"
43 D ^DIC
44 K DLAYGO
45 G:Y'>0 EXIT
46 S DA=+Y
47 L +^PRCS(410,DA):1 ; Lock new ien
48 I $T=0 W !," Cannot create new number now...please try again later" G EXIT
49 ; clean up txn x-refs for old & new ien's (nodes 'B','B2','B3','AE')
50 K ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$P(TX1,"-",5),DA),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA),^PRCS(410,"AE",$P(TX1,"-",1,4),DA)
51 ; kill x-refs to old ien
52 K ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$P(T2,"-",5),T1),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),T1),^PRCS(410,"AE",$P(T2,"-",1,4),T1)
53 ; set old txn name into new ien
54 S $P(^PRCS(410,DA,0),"^")=T2
55 ; set x-refs of old txn values to new ien
56 S (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$P(T2,"-",5),DA),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),DA),^PRCS(410,"AE",$P(T2,"-",1,4),DA))=""
57CK1 ; set new txn name into old (original) ien
58 S $P(^PRCS(410,T1,0),"^")=TX1
59 ; set x-refs of new txn values to old ien
60 S (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$P(TX1,"-",5),T1),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),T1),^PRCS(410,"AE",$P(TX1,"-",1,4),T1))=""
61 ; delete old txn from temp txn x-ref & remove temp txn flag
62 K ^PRCS(410,"K",+T3,ODA) S $P(^PRCS(410,ODA,6),"^",4)=""
63 S PRC("OCP")=$P(^PRCS(410,ODA,3),U)
64 ; if old txn name is non-numeric (temp txn), force new site & CP into record at old ien
65 I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE G EN
66 ; else: cancel txn at old ien; force old site & CP info into new ien
67 ;(Shortened comment and added cancel flag with patch 182
68 S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3
69 S DR=DR_";60///Transaction "_T2_" replaced by trans. "_TX1
70 S DR=DR_";450///C" ;put cancel flag in Running Bal status
71 D ^DIE
72 I T5'="" S $P(^PRCS(410,DA,0),U,10)=T5 ; save substation in new ien
73 S $P(^PRCS(410,DA,0),U,2)="CA" ; cancel txn at new ien
74 D ERS410^PRC0G(DA_"^C")
75 D W5^PRCSEB ; kill flags & x-refs indicating cancel txn is ready to approve
76 L -^PRCS(410,DA) ; release new ien
77 W !,"Old transaction "_T2_" is now cancelled.",!
78 I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK
79EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,!
80 S PNW=ODA,PNW(1)=TX1
81 N A,B
82 S A=TX1 D RBQTR ; returns B for DR string (RB Qrtr date)
83 S DA=PNW,DR=B_$S(+T2:"1///"_T4,1:"")_$S(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"")
84 D ^DIE
85 S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
86 S PRCSAPP=$P(PRC("ACC"),"^",11)
87 S $P(^PRCS(410,DA,3),"^")=PRC("CP")
88 S $P(^PRCS(410,DA,3),"^",2)=PRCSAPP
89 S $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
90 S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
91 N MYY S MYY="" D EN2B^PRCSUT3 ; save substation & process with status of entered
92 D K^PRCSUT1 ; kill 'F', 'F1', x-refs
93 K T1(1)
94 S (DA,PRCS,PRCSY)=PNW
95 I $P(^PRCS(410,DA,0),"^",4)=1 D G ANTN:%=1,EXIT
96 . S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
97 . W !,"Use the 1358 edit option ",$S(AA<0:"",1:"if you wish "),"to edit this request.",!! D EXIT,W3
98 ; restore values associated with new txn (use new name)
99 S PRC("SITE")=$P(PNW(1),"-"),PRC("FY")=$P(PNW(1),"-",2),PRC("QTR")=$P(PNW(1),"-",3),PRC("CP")=$P(PNW(1),"-",4),PRCSQ=1
100 S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0)
101 I AA<0 W !,"Use the Edit a 2237 option to edit this request.",!! D EXIT,W3 G ANTN:%=1,EXIT
102 E D W1 ; ask 'edit this request?'
103 I %=2 D W6^PRCSEB G EN1 ; if no, may ask if ready for authorization
104 D:%=1 EDTD1^PRCSEB0 D:'$D(PRCSQ)&(T4="O") W6^PRCSEB
105EN1 K PRCSQ
106 L -^PRCS(410,ODA)
107 D W3 I %=1 D EXIT W !! G ANTN1
108 G EXIT
109 ;
110PRCFY S A=PRCSAPP I A["_/_" D FY2 G KILL
111 I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2)
112KILL K %DT,A,B,RES,X
113 Q
114 ;
115FY2 ;TWO YR APP
116 I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(100+$E(X,4)+$E(X,2,3),2,3)
117 W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21
118 I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2
119FY21 S:'RES RES=PRC("FY")
120 S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3)
121 Q
122 ;
123REVIEW W !!,"Would you like to review this request"
124 S %=2 D YN^DICN G REVIEW:%=0
125 Q:%'=1
126 S (N,PRCSZ)=DA,PRCSF=1
127 D PRF1^PRCSP1 ; print 2237
128 S DA=PRCSZ
129 K X,PRCSF,PRCSZ
130 Q
131 ;
132W1 S %=2 Q:T4'="O"
133 W !!,"Would you like to edit this request"
134 D YN^DICN G W1:%=0
135 Q
136 ;
137W3 W !!,"Would you like to replace another transaction number"
138 S %=2 D YN^DICN G W3:%=0
139 Q
140 ;
141W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5
142EXIT I $D(ODA) L -^PRCS(410,ODA)
143 D EXIT^PRCSUT31
144 Q
145 ;
146MO ;MO QRTR
147 I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
148 I PRCSQT=1 W !?3,"10 OCT",!?3,"11 NOV",!?3,"12 DEC" Q
149 I PRCSQT=2 W !?3," 1 JAN",!?3," 2 FEB",!?3," 3 MAR" Q
150 I PRCSQT=3 W !?3," 4 APR",!?3," 5 MAY",!?3," 6 JUN" Q
151 I PRCSQT=4 W !?3," 7 JUL",!?3," 8 AUG",!?3," 9 SEP" Q
152 Q
153 ;
154MO1 I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q
155 S PRCSMO=$S(X<4:2,X>9:1,X>3&(X<7):3,X>6&(X<10):4,1:"")
156 I PRCSMO="" K PRCSMO
157 Q
158 ;
159RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I"))
160 S C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B)
161 S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7)
162 S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)<D:$P(C,"^",2),1:D)
163 S B="449////"_B_";"
164 QUIT
Note: See TracBrowser for help on using the repository browser.