source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSEA.m@ 1150

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

initial load of WorldVistAEHR
File size: 9.4 KB
Line 
1PRCSEA ;WISC/SAW/DXH/BM/SC/DAP - CONTROL POINT ACTIVITY EDITS ; 3/31/05 2:59pm
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code
6 ;to update Audit file (#414.02), and send update message to
7 ;DynaMed thru a call to rtn PRCVTCA.
8 ;
9ENRS ;ENTER REQ
10 S PRCSK=1,X3="H"
11 D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197
12 G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered
13 D W6 ; display help on transaction# format
14ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H"
15 S DIC("A")="Select TRANSACTION: "
16 S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match
17 D ^PRCSDIC ; lookup & preliminary validity checking
18 K DLAYGO,DIC("A"),DIC("S")
19 G:Y<0 EXIT
20 I $P(Y,U,3)'=1 W $C(7)," Must be a new entry." G ENRS0
21 ;*81 Check site parameter to see if issue books are allowed
22 D CKPRM^PRCSEB
23 W !!,PRCVY,!
24 S (PDA,T1,DA)=+Y
25 L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0
26 S T(2)=$P(Y,U,2)
27 D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410)
28 S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by)
29 S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default
30 I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point
31 S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM
32 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1
33TYPE ;
34 W !!,"This transaction is assigned temporary transaction number: ",T(2)
35 S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ"
36 S DIC("S")=PRCVX ; only allow selection of 2237's
37 D ^DIC
38 S DA=PDA
39 ;if user didn't enter a form type, go ask whether to backout and act
40 ;accordingly: go let them re-enter a form type or exit
41 I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT
42 ;
43 I Y<2 W "??" G TYPE
44 K PRCVX,PRCVY
45 S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type
46 ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes',
47 ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated.
48 S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
49 K PRCSERR ; flag denoting item info is missing
50 S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
51 S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
52EN1 K DTOUT,DUOUT,Y
53 D ^DIE
54 S DA=PDA
55 I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT
56 D RL^PRCSUT1 ; sets up 'IT' & '10' nodes
57 D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item')
58 D DOR ; populate date of request field if it is nil
59 L -^PRCS(410,DA)
60 S T="enter" D W5 G EXIT:%'=1
61 W !! K PRCS("SUB")
62 G ENRS
63 ;
64EDRS ;EDIT REQ
65 ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn
66 ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197
67 ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user
68 D W6 ; format doc for txn#
69 S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H"
70 S DIC("A")="Select TRANSACTION: "
71 S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358
72 D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
73 S (PDA,DA,T1)=+Y
74 L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS
75 ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option
76 ; D EN2B^PRCSUT3
77 S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5)
78 S PRC("CP")=$P(^PRCS(410,PDA,3),"^")
79 I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197
80 . N PRCSIP D IP^PRCSUT
81 . I $D(PRCSIP) S $P(^PRC(410,DA,0),U,6)=PRCSIP
82 S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM
83 ;*81 Check site parameter to see if Issue Books are allowed
84 D CKPRM
85 I PRCVD=1 S PRCVZ=1
86 I PRCVD'=1 S PRCVZ=0
87 W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),!
88 I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS
89 ;
90 S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410,"
91 ;P182--Modified next 3 lines to use new templates if supply fund FCP
92 S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]"
93ED1 K DTOUT,DUOUT,Y
94 D ^DIE
95 S DA=PDA
96 I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT
97 D RL^PRCSUT1
98 D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1
99 K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ
100 L -^PRCS(410,DA)
101 S T="edit" D W5 G EXIT:%'=1
102 W !! K PRCS("SUB")
103 G EDRS
104 ;
105CT ;CANCEL A (PERMANENT) TRANS
106 D EN3^PRCSUT
107 G W2:'$D(PRC("SITE")),EXIT:Y<0
108 S DIC="^PRCS(410,",DIC(0)="AEMQ"
109 ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
110 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)))"
111 S DIC("A")="Select TRANSACTION: "
112 D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A")
113CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1
114 S DA=+Y
115 L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT
116 S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0
117 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)
118 K ZX
119 I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
120 I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX
121 I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 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)
122 D ERS410^PRC0G(DA_"^C")
123 W !,"Enter comments for this cancellation",!
124 S DIE=DIC,DR=60
125 D ^DIE
126 ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM
127 D EN^PRCVTCA(DA)
128 L -^PRCS(410,DA)
129 I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
130 S T="cancel" D W4 G EXIT:%'=1
131 W !! G CT
132 ;
133DT ;DELETE A (TEMPORARY) TRANS
134 S X3="H"
135 D W6 ; format doc for txn#
136 S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H"
137 S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))"
138 D ^PRCSDIC G EXIT:Y<0
139 K DIC("S"),DIC("A")
140 S DA=+Y
141 L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT
142DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1
143 ;The following line was commented out in patch 182; should NOT manually
144 ;change or reset last assigned IEN # in node zero.
145 ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC
146 S DIK=DIC
147 W !,"Okay....."
148 D ^DIK K DIK
149 L -^PRCS(410,DA)
150 ;The following line was commented out in patch 182; should NOT manually
151 ;change or reset last assigned IEN # in node zero.
152 ;S $P(^PRCS(410,0),U,3)=PRCSDA
153 K PRCSDA
154 W "It's deleted"
155 S T="delete" D W4 G EXIT:%'=1
156 W !! G DT
157 ;
158 ;
159DOR ; Date of Request
160 I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q
161 S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y
162 Q
163FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed
164 D CKPRM
165 I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option."
166 I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option."
167 W !,PRCVY1,!
168 W !,"Please enter another form type",!
169 S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ"
170 S DIC("S")=PRCVX1
171 D ^DIC
172 S:Y=-1 Y=2
173 S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y
174 K DIC,PRCVX1,PRCVY1,PRCVD
175 Q
176 ;
177 ;Allow user the option of re entering a form type. If they decline,
178 ;kill off the transaction and return 1; else return 0
179BACKOUT(TRNNAME,TRNDA) ;
180 N DIK,Y,%,DA
181 W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7)
182 W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN
183 I %=0 G BACKOUT
184 I %=2 Q 0
185 S DIK="^PRCS(410,",DA=TRNDA
186 D ^DIK
187 Q 1
188 ;
189W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT
190W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140
191 W !!,"This transaction is assigned temporary transaction number: ",X Q
192W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q
193W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q
194W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q
195 ;*81 Site parameter pull
196CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
197 Q
198 ;
199EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ
200 I $D(PRCSERR) K PRCSERR
201 Q
Note: See TracBrowser for help on using the repository browser.