source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSECP1.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1PRCSECP1 ;SF-ISC/LJP/DGL-COPY A TRANSACTION CON'T ; 7/29/99 1:54pm
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4S1 ;subroutine to copy transactions of form type 1 (i.e. 1358)
5 K PRCSTMP
6 N I,PRCSIP
7 I $D(^PRCS(410,T1,0)) D
8 . F I=2,4 S $P(^PRCS(410,DA,0),U,I)=$P(^PRCS(410,T1,0),U,I)
9 . D IP^PRCSUT
10 . I $G(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP
11 S:$D(^PRCS(410,T1,1)) $P(^PRCS(410,DA,1),U,5)=$P(^(1),U,5)
12 I $D(^PRCS(410,T1,3)) S PRCSTMP=^(3),^PRCS(410,DA,3)=$P(^PRCS(410,DA,3),U,1,2)_"^"_$P(PRCSTMP,U,3,6)_"^^"_$P(PRCSTMP,U,8)_"^^"_$P(PRCSTMP,U,10)
13 I $P(PRCSTMP,U)'=$P(^PRCS(410,DA,3),U) S $P(^PRCS(410,DA,3),U,3)=""
14 S:$D(^PRCS(410,T1,10)) $P(^PRCS(410,DA,10),U)=$P(^(10),U)
15 ;
16 D CHECK
17 D S4,S5,S7
18 Q
19 ;
20 ;subroutine S2 is called to copy all transactions of form type <> 1
21 ;(anything other than a 1358)
22S2 K PRCSTMP
23 N I,PRCSIP
24 ;if possible, copy over transaction type & form type from old trans.
25 ;also get inventory distrib. point from NEW FCP inv distrib point
26 I $D(^PRCS(410,T1,0)) D
27 . F I=2,4 S $P(^PRCS(410,DA,0),U,I)=$P(^PRCS(410,T1,0),U,I)
28 . D IP^PRCSUT
29 . I $D(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP
30 ;copy classification of request
31 I $D(^PRCS(410,T1,1)) S $P(^PRCS(410,DA,1),U,5)=$P(^(1),U,5)
32 ;now copy cost center, vendor, requesting service, and vendor contract #
33 ;"CHECK" checks for valid FCP user, CC, BOC, etc.
34 I $D(^PRCS(410,T1,3)) D
35 . F I=3,4,5,10 S $P(^PRCS(410,DA,3),U,I)=$P(^PRCS(410,T1,3),U,I)
36 . I $P(^PRCS(410,T1,3),U)'=$P(^PRCS(410,DA,3),U) S $P(^PRCS(410,DA,3),U,3)=""
37 . D CHECK
38 ;copy the line item count
39 S:$D(^PRCS(410,T1,10)) $P(^PRCS(410,DA,10),U)=$P(^(10),U)
40 ;S:$D(^PRCS(410,T1,9)) $P(^PRCS(410,DA,9),U,1)=$P(^(9),U,1)
41 ;
42 D S4,S5,S7
43 Q
44 ;
45S3 ;Note: S3 commented out (prior to patch 182) so it falls through to S4
46 ;K PRCSTMP
47 ;S:$D(^PRCS(410,T1,3)) $P(^PRCS(410,DA,3),U,3)=$P(^(3),U,3) D CHECK
48 ;I $D(^PRCS(410,T1,"CO",0)) S ^PRCS(410,DA,"CO",0)=$P(^(0),U,1,4)_"^"_DT,PRCSI="CO",PRCSK=0 D S6
49 ;D S4 Q
50 ;
51 ;
52S4 ;copy vendor info and sort group
53 ;
54 S:$D(^PRCS(410,T1,2)) ^PRCS(410,DA,2)=^(2)
55 S:$D(^PRCS(410,T1,11)) ^PRCS(410,DA,11)=$P(^(11),U,1)
56 ;following line (copy sub control point) commented out before P182
57 ;I $D(^PRCS(410,T1,12,0)) S ^PRCS(410,DA,12,0)=^(0),PRCSI=12,PRCSK=0 D S6
58 Q
59 ;
60S5 ;copy special remarks (using S6)
61 S PRCSI="RM"
62 I $D(^PRCS(410,T1,PRCSI,0)) D
63 . S ^PRCS(410,DA,PRCSI,0)=$P(^(0),U,1,4)_"^"_DT,PRCSK=0
64 . D S6
65 Q
66 ;
67S6 ;General purpose copy used for remarks
68 F S PRCSK=$O(^PRCS(410,T1,PRCSI,PRCSK)) Q:'PRCSK D
69 . S:$D(^PRCS(410,T1,PRCSI,PRCSK,0)) ^PRCS(410,DA,PRCSI,PRCSK,0)=$P(^(0),U,1)
70 Q
71 ;
72S7 ;copy the items from the old transaction to the new
73 I $D(^PRCS(410,T1,"IT",0)) D
74 . S ^PRCS(410,DA,"IT",0)=^PRCS(410,T1,"IT",0)
75 . K PRCSTMP S PRCSK=0
76 . D S8
77 Q
78 ;
79S8 ;copy the items from old to new (detail)
80 F S PRCSK=$O(^PRCS(410,T1,"IT",PRCSK)) Q:'PRCSK I $D(^(PRCSK,0)) D
81 . S PRCSTMP=^PRCS(410,T1,"IT",PRCSK,0)
82 . S ^PRCS(410,DA,"IT",PRCSK,0)=$P(PRCSTMP,U,1,7)
83 . S PRCSL=0 D S9
84 Q
85S9 ;copy the items from old txn to new (further detail)
86 N PRCSTMP
87 I $D(GET1) S $P(^PRCS(410,DA,"IT",PRCSK,0),"^",4)=GET1
88 I $D(^PRCS(410,T1,"IT",PRCSK,1,0)) S PRCSTMP=^(0) D
89 . S ^PRCS(410,DA,"IT",PRCSK,1,0)=$P(PRCSTMP,U,1,4)_"^"_DT
90 F S PRCSL=$O(^PRCS(410,T1,"IT",PRCSK,1,PRCSL)) Q:'PRCSL D
91 . L -^PRCS(410,DA)
92 . I $D(^PRCS(410,T1,"IT",PRCSK,1,PRCSL,0)) S PRCSTMP=^(0),^PRCS(410,DA,"IT",PRCSK,1,PRCSL,0)=PRCSTMP
93 Q
94CHECK ;Check for valid CC/BOC on the FCP for this transaction
95 ;if old trans didn't have an FCP stop right now
96 N TEST S TEST=$P($G(^PRCS(410,T1,3)),"^",3) Q:TEST=""
97 S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
98 S PRCSAPP=$P(PRC("ACC"),"^",11)
99 S $P(^PRCS(410,DA,3),U)=PRC("CP"),$P(^(3),"^",2)=PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3)
100 S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
101 S $P(^PRCS(410,DA,7),U)=DUZ,$P(^PRCS(410,DA,7),U,2)=$P($G(^VA(200,DUZ,20)),U,3)
102 ;P182--Commented out following 4 lines which were determining a default
103 ;CC and attempting to get a default BOC. Now this is accomplished in
104 ;CHGCCBOC^PRCSCK, which is called upon return to ^PRCSECP
105 ;I '$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,TEST)) D
106 ;.S GET=0 S GET=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,GET)) Q:+GET=0
107 ;.Q:'$D(^PRCD(420.1,GET)) S GET1=0 S GET1=$O(^PRCD(420.1,GET,1,GET1)) Q:'$D(^PRCD(420.2,GET1)) S GET1=$E(^PRCD(420.2,GET1,0),1,30)
108 ;.Q:+GET1=0 S $P(^PRCS(410,DA,3),"^",3)=GET
109 Q
110W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
111W3 W !!,"Would you like to copy another request" S %=1 D YN^DICN G W3:%=0 Q
Note: See TracBrowser for help on using the repository browser.