source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSCPY.m@ 1046

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1PRCSCPY ;WISC/KMB/DXH/DAP - COPY OLD TEMP. REQUEST TO NEW ; 7.23.99
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 N X3,T,T1,PRCSDR,OLDA,NEWDA,PRCDAA,PRCSAPP,PRCSK,NEWTEMP,OLD0NODE,OLD3NODE,I,J,PRCK,PRCHFLG
6 ;
7START ;
8 W !!
9 ; S PRCSK=1 ; flag to allow any user to select any site
10 ; next line commented out in PRC*5*140 - user responses not used
11 ; D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:Y<0
12 S X3="H",DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select transaction to be copied: "
13 S DIC("S")="I $P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or be unauthored
14 D ^PRCSDIC K DIC("A"),DIC("S")
15 G EXIT:Y<0 ; user entered '^'
16 S (OLDA,DA)=+Y ; subscript/internal# to file 410
17 L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...please try later") Q
18 D REVIEW
19 S PRCVFT=$P(^PRCS(410,DA,0),"^",4)
20 ;*81 Check site parameter to see if Issue Books are allowed
21 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1
22 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0
23 I PRCVZ=1,PRCVFT=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order." D CLEAN G START
24 K DA,DIC,PRCVFT,PRCVZ
25 I $D(%) G EXIT:%=-1
26ENTRY ;
27 D EN^DDIOL("Please enter information for the transaction being created.")
28 W !
29 S PRCSK=1 ; allow user to select any station on system
30 D EN1F^PRCSUT(1) ;ask site, FY, QRTR, CP & store in PRC array, set up PRCSIP
31 G W2:'$D(PRC("SITE")) ; only happens if there are no stations on system?
32 G EXIT:Y<0
33EN1 D EN^DDIOL("Please enter a new transaction in the format 'A1234'")
34 W !
35 S DIC("A")="Enter new temporary transaction number: "
36 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="L",D="H"
37 S DIC("S")="I '^(0),$P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match, display doesn't filter for station,CP,FY,or QRTR
38 D ^PRCSDIC S NEWTEMP=X K DLAYGO,DIC("A"),DIC("S") G:Y<0 EXIT
39 I $D(^PRCS(410,"H",$P(Y,U,2)))
40 I D EN^DDIOL("Must be a new and different temporary number.","","!!") G EN1
41 S (NEWDA,T1,DA)=+Y ; subscript/internal# to file 410 for new txn
42 ;
43PROCESS ;ERC-10/96 Revised copy of fields into new transaction
44 L +^PRCS(410,NEWDA):1 ; lock file being created
45 I $T=0 D EN^DDIOL("File being accessed...please try a different number or try later") G EN1
46 D EN^DDIOL("Transaction data is being copied.","","!?10") W !
47 S T(2)=NEWTEMP
48 D EN2A^PRCSUT3 ; sets up sta,substa,BBFY,author,CP,ACC,rb code,etc
49 S OLD0NODE=^PRCS(410,OLDA,0),OLD3NODE=^PRCS(410,OLDA,3)
50 F I=2,4 S $P(^PRCS(410,NEWDA,0),U,I)=$P(OLD0NODE,U,I) ; txn type,format
51 ; note that for any FCP that is not automated,the form type is not forced to be non repetitive. This may be because full implementation of IFCAP is mandatory.
52 I $D(PRCSIP) S $P(^PRCS(410,NEWDA,0),U,6)=PRCSIP ; inventory distrib point, 'AO' xref will be set by XREF subroutine
53 S %DT="X",X="T" D ^%DT ; get today in internal date format
54 S $P(^PRCS(410,NEWDA,1),U)=Y ; & store as date of request
55 I $D(^PRCS(410,OLDA,2)) S ^PRCS(410,NEWDA,2)=^PRCS(410,OLDA,2) ; vendor info may not be on 1358's
56 F I=4:1:10 S $P(^PRCS(410,NEWDA,3),U,I)=$P(OLD3NODE,U,I)
57 I $P(OLD3NODE,U)'=PRC("CP") S PRCHFLG=1 ; different CP
58 E S $P(^PRCS(410,NEWDA,3),U,3)=$P(OLD3NODE,U,3)
59 F I=4,10 I $D(^PRCS(410,OLDA,I)) S $P(^PRCS(410,NEWDA,I),U)=$P(^PRCS(410,OLDA,I),U)
60 I $P(^PRCS(410,NEWDA,0),U,4)=1 ;1358 needs Date Committed
61 I S $P(^PRCS(410,NEWDA,4),U,2)=$E($P(^PRCS(410,NEWDA,1),U),1,5)_"01"
62 S $P(^PRCS(410,DA,7),U)=DUZ ; PRC140 - this line moved from FINAL
63 S $P(^PRCS(410,DA,14),U)=DUZ
64 I $D(^PRCS(410,OLDA,"RM",0)) S ^PRCS(410,NEWDA,"RM",0)=$P(^PRCS(410,OLDA,"RM",0),U,1,4)_"^"_DT,PRCK=0 D
65 . F J=0:0 S PRCK=$O(^PRCS(410,OLDA,"RM",PRCK)) Q:'PRCK S:$D(^PRCS(410,OLDA,"RM",PRCK,0)) ^PRCS(410,NEWDA,"RM",PRCK,0)=$P(^PRCS(410,OLDA,"RM",PRCK,0),U)
66 S T1=OLDA,DA=NEWDA
67 D S7^PRCSECP1 ; copy 'IT' subnode from the old transaction
68 ;new transaction has different FCP from old txn
69 I +$G(PRCHFLG) S PRCHFLG=$$CHGCCBOC^PRCSCK($P($G(^PRCS(410,T1,0)),U),$P($G(^PRCS(410,NEWDA,0)),U),$P($G(^PRCS(410,OLDA,3)),U,3),0)
70 ;I '$G(PRCHFLG) G P2 ; new transaction has same CP as original
71 ;D SRCH I X'="" S:X'=1 $P(^PRCS(410,NEWDA,3),U,3)=X G P1
72 ;S DA=NEWDA,DR=15.5,DIE="^PRCS(410," D ^DIE ; ask cost center
73 ;I $D(Y)'=0 D XREF G EXIT ; user entered '^'
74 I ($G(PRCHFLG)<-1) D XREF G EXIT ; user entered '^'
75P1 K PRCHFLG
76P2 S DIC(0)="AEMQ",DIE=DIC,DR=7 D ^DIE ; ask Date required
77 I $D(Y)'=0 D XREF G EXIT ; user entered '^'
78 D XREF G EDIT
79XREF S DA=NEWDA,DIK="^PRCS(410," D IX^DIK ; set up X-refs for new transaction
80 Q
81EDIT ;
82 S %=2 D EN^DDIOL("Would you like to edit this entry")
83 D YN^DICN G EDIT:%=0 G EXIT:%=-1 G:%=2 FINAL
84EDIT1 ;
85 S X=+$P($G(^PRCS(410,DA,0)),"^",4) ; X is form type
86 ;*81 Check site parameter to see if issue books should be allowed
87 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The Issue Book and NO FORM types are not valid in this option."
88 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The NO FORM type is not valid in this option."
89 I X<1 D
90 . S DA=NEWDA
91 . D EN^DDIOL(PRCVY)
92 . D EN^DDIOL("Please enter another form type.","","!!")
93 . W !
94 . S DIC="^PRCS(410.5,"
95 . S DIC("A")="FORM TYPE: "
96 . S DIC(0)="AEQZ"
97 . S DIC("S")=PRCVX
98 . D ^DIC
99 . S:Y=-1 Y=2
100 . S $P(^PRCS(410,NEWDA,0),"^",4)=+Y,X=+Y
101 . K DIC,PRCVX,PRCVY
102 D EN^DDIOL("The form type of this request is "_$P($G(^PRCS(410.5,X,0)),"^"))
103 ; PRC140 - 2237 form types now use temporary transaction templates
104 S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",X=5:"PRCSENIBS",1:"PRCSENCOD")_"]"
105 K DTOUT,DUOUT,Y
106 S (DIE,DIC)="^PRCS(410,"
107 D ^DIE I $D(Y)!($D(DTOUT)) G EXIT
108 I +$P($G(^PRCS(410,DA,0)),"^",4)=1 G FINAL ; skip line item processing if this is a 1358
109 S DA=NEWDA D RL^PRCSUT1
110 D ^PRCSCK I $D(PRCSERR),PRCSERR G EDIT1
111 ;
112FINAL ;
113 W !! D CLEAN G START
114 ;
115REVIEW W !!,"Would you like to review this request" S %=2
116 D YN^DICN G REVIEW:%=0 I %'=1 Q
117 S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5)
118 S PRC("CP")=$P(^PRCS(410,DA,3),"^")
119 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=OLDA K X,PRCSF,PRCSZ Q
120 ;
121W2 D EN^DDIOL("You are not an authorized control point user.","","!!")
122 D EN^DDIOL("Contact your control point official")
123 R X:5 G EXIT
124W3 Q ;can this be deleted? - commented out in patch PRC*5*140
125 D EN^DDIOL("Would you like to copy another request","","!!")
126 S %=1 D YN^DICN G W3:%=0 G START:%=1 Q
127 ;
128SRCH ;FIND COST CENTER
129 ; returns x="" if there are multiple cc's, x=1 if no cc, x=cc if only 1
130 S X=0
131SRCH1 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
132 I X=""!(+X'=X) D EN^DDIOL("Transaction will be created but this control point has no active cost center","","!!") S X=1 Q
133 I '$D(^PRCD(420.1,X,0)) G SRCH1
134 I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH1
135 S Y=X ; found 1 cost center
136SRCH2 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
137 I X=""!(+X'=X) S X=$P(^PRCD(420.1,Y,0),U) Q ; save cost center
138 I '$D(^PRCD(420.1,X,0)) G SRCH2
139 I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH2
140 S X="" ; system can't select cost center - there is more than 1
141 Q
142CLEAN I $D(OLDA) L -^PRCS(410,OLDA)
143 I $D(NEWDA)=1 L -^PRCS(410,NEWDA)
144 K %,DA,DIC,X,Y,PRCSERR
145 Q
146 ;
147EXIT D CLEAN
148 Q
Note: See TracBrowser for help on using the repository browser.