PRCHCRD ;WISC/DJM,ID/RSD,TKW/SF-LINK REPETITIVE ITEM DATA TO P.O.ITEM DATA ;6/7/94 3:28 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN0 ;Edit unit of purchase from file 442 to file 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,7)=X G Q
EN1 ;Edit unitcost from file 442 to file 441
;Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,2)=X,$P(^(0),U,6)=$S($D(DT):DT,1:"") G Q ;;REPLACED WITH $G
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) Q:$G(PRCHPHAM) S $P(^(0),U,2)=X,$P(^(0),U,6)=$G(DT) G Q
EN2 ;Edit contract from file 442 to file 441. Called from EN8^PRCHNPO5.
Q:'$D(^PRC(440,PRCHCV,4,+Y,0))!('$D(^PRC(441,PRCHCI,2,PRCHCV,0))) S $P(^(0),U,3)=+Y G Q
EN5 ;Edit national stock no. from file 442 to 441
I $P(^PRC(441,+PRCHCI,0),U,5)]"" S Z=$P(^(0),U,5),Z(1)=$P(Z,"-",3,4),Z(2)=$E(Z,4)_$P(Z,"-",2)_$P(Z,"-",3)_$P(Z,"-",4) K ^PRC(441,"BB",Z,+PRCHCI) K:Z(1)]"" ^PRC(441,"BA",Z(1),+PRCHCI) K:Z(2)]"" ^PRC(441,"G",Z(2),+PRCHCI)
S Z(1)=$P(X,"-",3,4),Z(2)=$E(X,4)_$P(X,"-",2)_$P(X,"-",3)_$P(X,"-",4),^PRC(441,"BB",X,+PRCHCI)="" S:Z(1)]"" ^PRC(441,"BA",Z(1),+PRCHCI)="" S:Z(2)]"" ^PRC(441,"G",Z(2),+PRCHCI)=""
S $P(^PRC(441,+PRCHCI,0),U,5)=X G Q
EN6 ;Move Vendor Stock No. from file 442 to 441
Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) I $P(^(0),U,4)]"" K ^PRC(441,"D",$P(^(0),U,4),+PRCHCI,PRCHCV)
S $P(^PRC(441,+PRCHCI,2,PRCHCV,0),U,4)=X,^PRC(441,"D",X,+PRCHCI,PRCHCV)="" G Q
EN3 ;Move Repetitive Item data to file 442, adds FCP to file 441. From "AD" X-REF SET in file 442, field 40, subfield 1.5.
;PRCHCCP=FCP, PRCHCV=VENDOR, PRCHCPD=P.O.DATE, PRCHCI=REP.ITEM NO., PRCHCPO=P.O.RECORD NO.
S PRCHCX=PRC("SITE")_PRCHCCP D CHK I '$D(^PRC(441,PRCHCI,4,PRCHCX,1,0)) S ^(0)="^441.04PA^0^0"
S:'$D(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO,0)) ^(0)=PRCHCPO,^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHCPO)="",$P(^(0),U,3,4)=PRCHCPO_U_($P(^PRC(441,PRCHCI,4,PRCHCX,1,0),U,4)+1)
G LST^PRCHCRD1
EN4 ;Delete UIR from file 442, kills FCP in file 441. From "AD" X-REF KILL in file 442, field 40, subfield 1.5.
S PRCHCX=PRC("SITE")_PRCHCCP G:'$D(^PRC(441,PRCHCI,4,PRCHCX,1,0)) Q
I $D(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO)) S $P(^(0),U,4)=$P(^(0),U,4)-1 K ^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO),^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHCPO)
G Q
CHK I '$D(^PRC(441,PRCHCI,4)) S ^PRC(441,PRCHCI,4,0)="^441.03A^0^0"
I '$D(^PRC(441,PRCHCI,4,PRCHCX,0)) S ^(0)=PRCHCX,^PRC(441,PRCHCI,4,"B",PRCHCX,PRCHCX)="",$P(^(0),U,3,4)=PRCHCX_U_($P(^PRC(441,PRCHCI,4,0),U,4)+1)
Q
LCK L +^PRC(441,X,0):5 E W !?8,"Item is being edited by another user, try later ",$C(7) K X
Q
Q K PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHC,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCRD 2804 printed Apr 09, 2024@21:14:24 Page 2
PRCHCRD ;WISC/DJM,ID/RSD,TKW/SF-LINK REPETITIVE ITEM DATA TO P.O.ITEM DATA ;6/7/94 3:28 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN0 ;Edit unit of purchase from file 442 to file 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
SET $PIECE(^(0),U,7)=X
GOTO Q
EN1 ;Edit unitcost from file 442 to file 441
+1 ;Q:'$D(^PRC(441,+PRCHCI,2,PRCHCV,0)) S $P(^(0),U,2)=X,$P(^(0),U,6)=$S($D(DT):DT,1:"") G Q ;;REPLACED WITH $G
+2 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
if $GET(PRCHPHAM)
QUIT
SET $PIECE(^(0),U,2)=X
SET $PIECE(^(0),U,6)=$GET(DT)
GOTO Q
EN2 ;Edit contract from file 442 to file 441. Called from EN8^PRCHNPO5.
+1 if '$DATA(^PRC(440,PRCHCV,4,+Y,0))!('$DATA(^PRC(441,PRCHCI,2,PRCHCV,0)))
QUIT
SET $PIECE(^(0),U,3)=+Y
GOTO Q
EN5 ;Edit national stock no. from file 442 to 441
+1 IF $PIECE(^PRC(441,+PRCHCI,0),U,5)]""
SET Z=$PIECE(^(0),U,5)
SET Z(1)=$PIECE(Z,"-",3,4)
SET Z(2)=$EXTRACT(Z,4)_$PIECE(Z,"-",2)_$PIECE(Z,"-",3)_$PIECE(Z,"-",4)
KILL ^PRC(441,"BB",Z,+PRCHCI)
if Z(1)]""
KILL ^PRC(441,"BA",Z(1),+PRCHCI)
if Z(2)]""
KILL ^PRC(441,"G",Z(2),+PRCHCI)
+2 SET Z(1)=$PIECE(X,"-",3,4)
SET Z(2)=$EXTRACT(X,4)_$PIECE(X,"-",2)_$PIECE(X,"-",3)_$PIECE(X,"-",4)
SET ^PRC(441,"BB",X,+PRCHCI)=""
if Z(1)]""
SET ^PRC(441,"BA",Z(1),+PRCHCI)=""
if Z(2)]""
SET ^PRC(441,"G",Z(2),+PRCHCI)=""
+3 SET $PIECE(^PRC(441,+PRCHCI,0),U,5)=X
GOTO Q
EN6 ;Move Vendor Stock No. from file 442 to 441
+1 if '$DATA(^PRC(441,+PRCHCI,2,PRCHCV,0))
QUIT
IF $PIECE(^(0),U,4)]""
KILL ^PRC(441,"D",$PIECE(^(0),U,4),+PRCHCI,PRCHCV)
+2 SET $PIECE(^PRC(441,+PRCHCI,2,PRCHCV,0),U,4)=X
SET ^PRC(441,"D",X,+PRCHCI,PRCHCV)=""
GOTO Q
EN3 ;Move Repetitive Item data to file 442, adds FCP to file 441. From "AD" X-REF SET in file 442, field 40, subfield 1.5.
+1 ;PRCHCCP=FCP, PRCHCV=VENDOR, PRCHCPD=P.O.DATE, PRCHCI=REP.ITEM NO., PRCHCPO=P.O.RECORD NO.
+2 SET PRCHCX=PRC("SITE")_PRCHCCP
DO CHK
IF '$DATA(^PRC(441,PRCHCI,4,PRCHCX,1,0))
SET ^(0)="^441.04PA^0^0"
+3 if '$DATA(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO,0))
SET ^(0)=PRCHCPO
SET ^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHCPO)=""
SET $PIECE(^(0),U,3,4)=PRCHCPO_U_($PIECE(^PRC(441,PRCHCI,4,PRCHCX,1,0),U,4)+1)
+4 GOTO LST^PRCHCRD1
EN4 ;Delete UIR from file 442, kills FCP in file 441. From "AD" X-REF KILL in file 442, field 40, subfield 1.5.
+1 SET PRCHCX=PRC("SITE")_PRCHCCP
if '$DATA(^PRC(441,PRCHCI,4,PRCHCX,1,0))
GOTO Q
+2 IF $DATA(^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO))
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)-1
KILL ^PRC(441,PRCHCI,4,PRCHCX,1,PRCHCPO),^PRC(441,PRCHCI,4,PRCHCX,1,"AC",9999999-PRCHCPD,PRCHCPO)
+3 GOTO Q
CHK IF '$DATA(^PRC(441,PRCHCI,4))
SET ^PRC(441,PRCHCI,4,0)="^441.03A^0^0"
+1 IF '$DATA(^PRC(441,PRCHCI,4,PRCHCX,0))
SET ^(0)=PRCHCX
SET ^PRC(441,PRCHCI,4,"B",PRCHCX,PRCHCX)=""
SET $PIECE(^(0),U,3,4)=PRCHCX_U_($PIECE(^PRC(441,PRCHCI,4,0),U,4)+1)
+2 QUIT
LCK LOCK +^PRC(441,X,0):5
IF '$TEST
WRITE !?8,"Item is being edited by another user, try later ",$CHAR(7)
KILL X
+1 QUIT
Q KILL PRCHC,PRCHCCN,PRCHCCP,PRCHCDC,PRCHCI,PRCHCMX,PRCHCNS,PRCHCPD,PRCHCPK,PRCHC,PRCHCQ,PRCHCS,PRCHCSB,PRCHCSC,PRCHCUC,PRCHCUP,PRCHCV,PRCHCVS,PRCHCX,PRCHCY
QUIT
+1 QUIT
