112 lines
4.6 KiB
Mathematica
112 lines
4.6 KiB
Mathematica
PRCSECP1 ;SF-ISC/LJP/DGL-COPY A TRANSACTION CON'T ; 7/29/99 1:54pm
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
S1 ;subroutine to copy transactions of form type 1 (i.e. 1358)
|
|
K PRCSTMP
|
|
N I,PRCSIP
|
|
I $D(^PRCS(410,T1,0)) D
|
|
. F I=2,4 S $P(^PRCS(410,DA,0),U,I)=$P(^PRCS(410,T1,0),U,I)
|
|
. D IP^PRCSUT
|
|
. I $G(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP
|
|
S:$D(^PRCS(410,T1,1)) $P(^PRCS(410,DA,1),U,5)=$P(^(1),U,5)
|
|
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)
|
|
I $P(PRCSTMP,U)'=$P(^PRCS(410,DA,3),U) S $P(^PRCS(410,DA,3),U,3)=""
|
|
S:$D(^PRCS(410,T1,10)) $P(^PRCS(410,DA,10),U)=$P(^(10),U)
|
|
;
|
|
D CHECK
|
|
D S4,S5,S7
|
|
Q
|
|
;
|
|
;subroutine S2 is called to copy all transactions of form type <> 1
|
|
;(anything other than a 1358)
|
|
S2 K PRCSTMP
|
|
N I,PRCSIP
|
|
;if possible, copy over transaction type & form type from old trans.
|
|
;also get inventory distrib. point from NEW FCP inv distrib point
|
|
I $D(^PRCS(410,T1,0)) D
|
|
. F I=2,4 S $P(^PRCS(410,DA,0),U,I)=$P(^PRCS(410,T1,0),U,I)
|
|
. D IP^PRCSUT
|
|
. I $D(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP
|
|
;copy classification of request
|
|
I $D(^PRCS(410,T1,1)) S $P(^PRCS(410,DA,1),U,5)=$P(^(1),U,5)
|
|
;now copy cost center, vendor, requesting service, and vendor contract #
|
|
;"CHECK" checks for valid FCP user, CC, BOC, etc.
|
|
I $D(^PRCS(410,T1,3)) D
|
|
. F I=3,4,5,10 S $P(^PRCS(410,DA,3),U,I)=$P(^PRCS(410,T1,3),U,I)
|
|
. I $P(^PRCS(410,T1,3),U)'=$P(^PRCS(410,DA,3),U) S $P(^PRCS(410,DA,3),U,3)=""
|
|
. D CHECK
|
|
;copy the line item count
|
|
S:$D(^PRCS(410,T1,10)) $P(^PRCS(410,DA,10),U)=$P(^(10),U)
|
|
;S:$D(^PRCS(410,T1,9)) $P(^PRCS(410,DA,9),U,1)=$P(^(9),U,1)
|
|
;
|
|
D S4,S5,S7
|
|
Q
|
|
;
|
|
S3 ;Note: S3 commented out (prior to patch 182) so it falls through to S4
|
|
;K PRCSTMP
|
|
;S:$D(^PRCS(410,T1,3)) $P(^PRCS(410,DA,3),U,3)=$P(^(3),U,3) D CHECK
|
|
;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
|
|
;D S4 Q
|
|
;
|
|
;
|
|
S4 ;copy vendor info and sort group
|
|
;
|
|
S:$D(^PRCS(410,T1,2)) ^PRCS(410,DA,2)=^(2)
|
|
S:$D(^PRCS(410,T1,11)) ^PRCS(410,DA,11)=$P(^(11),U,1)
|
|
;following line (copy sub control point) commented out before P182
|
|
;I $D(^PRCS(410,T1,12,0)) S ^PRCS(410,DA,12,0)=^(0),PRCSI=12,PRCSK=0 D S6
|
|
Q
|
|
;
|
|
S5 ;copy special remarks (using S6)
|
|
S PRCSI="RM"
|
|
I $D(^PRCS(410,T1,PRCSI,0)) D
|
|
. S ^PRCS(410,DA,PRCSI,0)=$P(^(0),U,1,4)_"^"_DT,PRCSK=0
|
|
. D S6
|
|
Q
|
|
;
|
|
S6 ;General purpose copy used for remarks
|
|
F S PRCSK=$O(^PRCS(410,T1,PRCSI,PRCSK)) Q:'PRCSK D
|
|
. S:$D(^PRCS(410,T1,PRCSI,PRCSK,0)) ^PRCS(410,DA,PRCSI,PRCSK,0)=$P(^(0),U,1)
|
|
Q
|
|
;
|
|
S7 ;copy the items from the old transaction to the new
|
|
I $D(^PRCS(410,T1,"IT",0)) D
|
|
. S ^PRCS(410,DA,"IT",0)=^PRCS(410,T1,"IT",0)
|
|
. K PRCSTMP S PRCSK=0
|
|
. D S8
|
|
Q
|
|
;
|
|
S8 ;copy the items from old to new (detail)
|
|
F S PRCSK=$O(^PRCS(410,T1,"IT",PRCSK)) Q:'PRCSK I $D(^(PRCSK,0)) D
|
|
. S PRCSTMP=^PRCS(410,T1,"IT",PRCSK,0)
|
|
. S ^PRCS(410,DA,"IT",PRCSK,0)=$P(PRCSTMP,U,1,7)
|
|
. S PRCSL=0 D S9
|
|
Q
|
|
S9 ;copy the items from old txn to new (further detail)
|
|
N PRCSTMP
|
|
I $D(GET1) S $P(^PRCS(410,DA,"IT",PRCSK,0),"^",4)=GET1
|
|
I $D(^PRCS(410,T1,"IT",PRCSK,1,0)) S PRCSTMP=^(0) D
|
|
. S ^PRCS(410,DA,"IT",PRCSK,1,0)=$P(PRCSTMP,U,1,4)_"^"_DT
|
|
F S PRCSL=$O(^PRCS(410,T1,"IT",PRCSK,1,PRCSL)) Q:'PRCSL D
|
|
. L -^PRCS(410,DA)
|
|
. I $D(^PRCS(410,T1,"IT",PRCSK,1,PRCSL,0)) S PRCSTMP=^(0),^PRCS(410,DA,"IT",PRCSK,1,PRCSL,0)=PRCSTMP
|
|
Q
|
|
CHECK ;Check for valid CC/BOC on the FCP for this transaction
|
|
;if old trans didn't have an FCP stop right now
|
|
N TEST S TEST=$P($G(^PRCS(410,T1,3)),"^",3) Q:TEST=""
|
|
S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
|
|
S PRCSAPP=$P(PRC("ACC"),"^",11)
|
|
S $P(^PRCS(410,DA,3),U)=PRC("CP"),$P(^(3),"^",2)=PRCSAPP,$P(^(3),"^",12)=$P(PRC("ACC"),"^",3)
|
|
S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
|
|
S $P(^PRCS(410,DA,7),U)=DUZ,$P(^PRCS(410,DA,7),U,2)=$P($G(^VA(200,DUZ,20)),U,3)
|
|
;P182--Commented out following 4 lines which were determining a default
|
|
;CC and attempting to get a default BOC. Now this is accomplished in
|
|
;CHGCCBOC^PRCSCK, which is called upon return to ^PRCSECP
|
|
;I '$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,TEST)) D
|
|
;.S GET=0 S GET=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,GET)) Q:+GET=0
|
|
;.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)
|
|
;.Q:+GET1=0 S $P(^PRCS(410,DA,3),"^",3)=GET
|
|
Q
|
|
W1 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
|
|
W3 W !!,"Would you like to copy another request" S %=1 D YN^DICN G W3:%=0 Q
|