PRCSECP1 ;SF-ISC/LJP/DGL-COPY A TRANSACTION CON'T ;7/29/99
V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, 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, sort group and authoritie(s)
;
N PRC11
S:$D(^PRCS(410,T1,2)) ^PRCS(410,DA,2)=^(2)
I $D(^PRCS(410,T1,11)) S PRC11=^(11),^PRCS(410,DA,11)=$P(PRC11,"^")_"^^^"_$P(PRC11,"^",4,5)
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSECP1 4883 printed Nov 22, 2024@17:27:40 Page 2
PRCSECP1 ;SF-ISC/LJP/DGL-COPY A TRANSACTION CON'T ;7/29/99
V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
S1 ;subroutine to copy transactions of form type 1 (i.e. 1358)
+1 KILL PRCSTMP
+2 NEW I,PRCSIP
+3 IF $DATA(^PRCS(410,T1,0))
Begin DoDot:1
+4 FOR I=2,4
SET $PIECE(^PRCS(410,DA,0),U,I)=$PIECE(^PRCS(410,T1,0),U,I)
+5 DO IP^PRCSUT
+6 IF $GET(PRCSIP)
SET $PIECE(^PRCS(410,DA,0),U,6)=PRCSIP
End DoDot:1
+7 if $DATA(^PRCS(410,T1,1))
SET $PIECE(^PRCS(410,DA,1),U,5)=$PIECE(^(1),U,5)
+8 IF $DATA(^PRCS(410,T1,3))
SET PRCSTMP=^(3)
SET ^PRCS(410,DA,3)=$PIECE(^PRCS(410,DA,3),U,1,2)_"^"_$PIECE(PRCSTMP,U,3,6)_"^^"_$PIECE(PRCSTMP,U,8)_"^^"_$PIECE(PRCSTMP,U,10)
+9 IF $PIECE(PRCSTMP,U)'=$PIECE(^PRCS(410,DA,3),U)
SET $PIECE(^PRCS(410,DA,3),U,3)=""
+10 if $DATA(^PRCS(410,T1,10))
SET $PIECE(^PRCS(410,DA,10),U)=$PIECE(^(10),U)
+11 ;
+12 DO CHECK
+13 DO S4
DO S5
DO S7
+14 QUIT
+15 ;
+16 ;subroutine S2 is called to copy all transactions of form type <> 1
+17 ;(anything other than a 1358)
S2 KILL PRCSTMP
+1 NEW I,PRCSIP
+2 ;if possible, copy over transaction type & form type from old trans.
+3 ;also get inventory distrib. point from NEW FCP inv distrib point
+4 IF $DATA(^PRCS(410,T1,0))
Begin DoDot:1
+5 FOR I=2,4
SET $PIECE(^PRCS(410,DA,0),U,I)=$PIECE(^PRCS(410,T1,0),U,I)
+6 DO IP^PRCSUT
+7 IF $DATA(PRCSIP)
SET $PIECE(^PRCS(410,DA,0),U,6)=PRCSIP
End DoDot:1
+8 ;copy classification of request
+9 IF $DATA(^PRCS(410,T1,1))
SET $PIECE(^PRCS(410,DA,1),U,5)=$PIECE(^(1),U,5)
+10 ;now copy cost center, vendor, requesting service, and vendor contract #
+11 ;"CHECK" checks for valid FCP user, CC, BOC, etc.
+12 IF $DATA(^PRCS(410,T1,3))
Begin DoDot:1
+13 FOR I=3,4,5,10
SET $PIECE(^PRCS(410,DA,3),U,I)=$PIECE(^PRCS(410,T1,3),U,I)
+14 IF $PIECE(^PRCS(410,T1,3),U)'=$PIECE(^PRCS(410,DA,3),U)
SET $PIECE(^PRCS(410,DA,3),U,3)=""
+15 DO CHECK
End DoDot:1
+16 ;copy the line item count
+17 if $DATA(^PRCS(410,T1,10))
SET $PIECE(^PRCS(410,DA,10),U)=$PIECE(^(10),U)
+18 ;S:$D(^PRCS(410,T1,9)) $P(^PRCS(410,DA,9),U,1)=$P(^(9),U,1)
+19 ;
+20 DO S4
DO S5
DO S7
+21 QUIT
+22 ;
S3 ;Note: S3 commented out (prior to patch 182) so it falls through to S4
+1 ;K PRCSTMP
+2 ;S:$D(^PRCS(410,T1,3)) $P(^PRCS(410,DA,3),U,3)=$P(^(3),U,3) D CHECK
+3 ;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
+4 ;D S4 Q
+5 ;
+6 ;
S4 ;copy vendor info, sort group and authoritie(s)
+1 ;
+2 NEW PRC11
+3 if $DATA(^PRCS(410,T1,2))
SET ^PRCS(410,DA,2)=^(2)
+4 IF $DATA(^PRCS(410,T1,11))
SET PRC11=^(11)
SET ^PRCS(410,DA,11)=$PIECE(PRC11,"^")_"^^^"_$PIECE(PRC11,"^",4,5)
+5 ;following line (copy sub control point) commented out before P182
+6 ;I $D(^PRCS(410,T1,12,0)) S ^PRCS(410,DA,12,0)=^(0),PRCSI=12,PRCSK=0 D S6
+7 QUIT
+8 ;
S5 ;copy special remarks (using S6)
+1 SET PRCSI="RM"
+2 IF $DATA(^PRCS(410,T1,PRCSI,0))
Begin DoDot:1
+3 SET ^PRCS(410,DA,PRCSI,0)=$PIECE(^(0),U,1,4)_"^"_DT
SET PRCSK=0
+4 DO S6
End DoDot:1
+5 QUIT
+6 ;
S6 ;General purpose copy used for remarks
+1 FOR
SET PRCSK=$ORDER(^PRCS(410,T1,PRCSI,PRCSK))
if 'PRCSK
QUIT
Begin DoDot:1
+2 if $DATA(^PRCS(410,T1,PRCSI,PRCSK,0))
SET ^PRCS(410,DA,PRCSI,PRCSK,0)=$PIECE(^(0),U,1)
End DoDot:1
+3 QUIT
+4 ;
S7 ;copy the items from the old transaction to the new
+1 IF $DATA(^PRCS(410,T1,"IT",0))
Begin DoDot:1
+2 SET ^PRCS(410,DA,"IT",0)=^PRCS(410,T1,"IT",0)
+3 KILL PRCSTMP
SET PRCSK=0
+4 DO S8
End DoDot:1
+5 QUIT
+6 ;
S8 ;copy the items from old to new (detail)
+1 FOR
SET PRCSK=$ORDER(^PRCS(410,T1,"IT",PRCSK))
if 'PRCSK
QUIT
IF $DATA(^(PRCSK,0))
Begin DoDot:1
+2 SET PRCSTMP=^PRCS(410,T1,"IT",PRCSK,0)
+3 SET ^PRCS(410,DA,"IT",PRCSK,0)=$PIECE(PRCSTMP,U,1,7)
+4 SET PRCSL=0
DO S9
End DoDot:1
+5 QUIT
S9 ;copy the items from old txn to new (further detail)
+1 NEW PRCSTMP
+2 IF $DATA(GET1)
SET $PIECE(^PRCS(410,DA,"IT",PRCSK,0),"^",4)=GET1
+3 IF $DATA(^PRCS(410,T1,"IT",PRCSK,1,0))
SET PRCSTMP=^(0)
Begin DoDot:1
+4 SET ^PRCS(410,DA,"IT",PRCSK,1,0)=$PIECE(PRCSTMP,U,1,4)_"^"_DT
End DoDot:1
+5 FOR
SET PRCSL=$ORDER(^PRCS(410,T1,"IT",PRCSK,1,PRCSL))
if 'PRCSL
QUIT
Begin DoDot:1
+6 LOCK -^PRCS(410,DA)
+7 IF $DATA(^PRCS(410,T1,"IT",PRCSK,1,PRCSL,0))
SET PRCSTMP=^(0)
SET ^PRCS(410,DA,"IT",PRCSK,1,PRCSL,0)=PRCSTMP
End DoDot:1
+8 QUIT
CHECK ;Check for valid CC/BOC on the FCP for this transaction
+1 ;if old trans didn't have an FCP stop right now
+2 NEW TEST
SET TEST=$PIECE($GET(^PRCS(410,T1,3)),"^",3)
if TEST=""
QUIT
+3 SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+4 SET PRCSAPP=$PIECE(PRC("ACC"),"^",11)
+5 SET $PIECE(^PRCS(410,DA,3),U)=PRC("CP")
SET $PIECE(^(3),"^",2)=PRCSAPP
SET $PIECE(^(3),"^",12)=$PIECE(PRC("ACC"),"^",3)
+6 SET $PIECE(^PRCS(410,DA,3),"^",11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
+7 SET $PIECE(^PRCS(410,DA,7),U)=DUZ
SET $PIECE(^PRCS(410,DA,7),U,2)=$PIECE($GET(^VA(200,DUZ,20)),U,3)
+8 ;P182--Commented out following 4 lines which were determining a default
+9 ;CC and attempting to get a default BOC. Now this is accomplished in
+10 ;CHGCCBOC^PRCSCK, which is called upon return to ^PRCSECP
+11 ;I '$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,TEST)) D
+12 ;.S GET=0 S GET=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,GET)) Q:+GET=0
+13 ;.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)
+14 ;.Q:+GET1=0 S $P(^PRCS(410,DA,3),"^",3)=GET
+15 QUIT
W1 WRITE !!,"Would you like to review this request"
SET %=2
DO YN^DICN
if %=0
GOTO W1
if %'=1
QUIT
SET (N,PRCSZ)=DA
SET PRCSF=1
DO PRF1^PRCSP1
SET DA=PRCSZ
KILL X,PRCSF,PRCSZ
QUIT
W3 WRITE !!,"Would you like to copy another request"
SET %=1
DO YN^DICN
if %=0
GOTO W3
QUIT
