PRCO441 ;ISC2/DJM-UPDATE UNIT OF ISSUE IN 441 FROM 445 ;11-13-92/12:05
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N A,B,C,D,E,F,G,FILE,ITEM,POINTER,UCF,UOFI,VENDOR,X,Y,Z,SKU
W !,"UPDATING 'UNIT CONVERSION FACTOR' AND 'SKU' IN FILE 441 FROM FILE 445.",!
S X=0 F S X=$O(^PRCP(445,X)) Q:X'>0 S A=$G(^PRCP(445,X,0)) I A]"" D:"WP"[$P(A,U,3)
.S Y=0 F S Y=$O(^PRCP(445,X,1,Y)) Q:Y'>0 S B=$G(^PRCP(445,X,1,Y,0)) I B]"" S ITEM=$P(B,U),UOFI=$P(B,U,5),E=$G(^PRC(441,ITEM,3)) S $P(E,U,8)=UOFI,^PRC(441,ITEM,3)=E D W "."
..S Z=0 F S Z=$O(^PRCP(445,X,1,Y,5,Z)) Q:Z'>0 S C=$G(^PRCP(445,X,1,Y,5,Z,0)) Q:C="" S POINTER=$P(C,U),FILE=$P(POINTER,";",2),VENDOR=$P(POINTER,";") I FILE="PRC(440," S UCF=$P(C,U,4) D
...S D=$G(^PRC(441,ITEM,2,VENDOR,0)) Q:D="" S F=$P(A,U,3),G=$P(D,U,10) I F="P",G="" S $P(D,U,10)=UCF,^PRC(441,ITEM,2,VENDOR,0)=D Q
...I F="W" S $P(D,U,10)=UCF,^PRC(441,ITEM,2,VENDOR,0)=D
...Q
..Q
.Q
S X=0 F S X=$O(^PRC(441,X)) Q:X'>0 S D=$G(^PRC(441,X,3)),SKU=$P(D,U,8) D W "."
.S Y=0 F S Y=$O(^PRC(441,X,2,Y)) Q:Y'>0 S A=$G(^PRC(441,X,2,Y,0)),B=$P(A,U,8),C=$P(A,U,10) S:C="" $P(A,U,10)=1,^PRC(441,X,2,Y,0)=A S:SKU="" $P(D,U,8)=B,^PRC(441,X,3)=D
.Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCO441 1237 printed Sep 23, 2025@19:47:39 Page 2
PRCO441 ;ISC2/DJM-UPDATE UNIT OF ISSUE IN 441 FROM 445 ;11-13-92/12:05
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW A,B,C,D,E,F,G,FILE,ITEM,POINTER,UCF,UOFI,VENDOR,X,Y,Z,SKU
+3 WRITE !,"UPDATING 'UNIT CONVERSION FACTOR' AND 'SKU' IN FILE 441 FROM FILE 445.",!
+4 SET X=0
FOR
SET X=$ORDER(^PRCP(445,X))
if X'>0
QUIT
SET A=$GET(^PRCP(445,X,0))
IF A]""
if "WP"[$PIECE(A,U,3)
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^PRCP(445,X,1,Y))
if Y'>0
QUIT
SET B=$GET(^PRCP(445,X,1,Y,0))
IF B]""
SET ITEM=$PIECE(B,U)
SET UOFI=$PIECE(B,U,5)
SET E=$GET(^PRC(441,ITEM,3))
SET $PIECE(E,U,8)=UOFI
SET ^PRC(441,ITEM,3)=E
Begin DoDot:2
+6 SET Z=0
FOR
SET Z=$ORDER(^PRCP(445,X,1,Y,5,Z))
if Z'>0
QUIT
SET C=$GET(^PRCP(445,X,1,Y,5,Z,0))
if C=""
QUIT
SET POINTER=$PIECE(C,U)
SET FILE=$PIECE(POINTER,";",2)
SET VENDOR=$PIECE(POINTER,";")
IF FILE="PRC(440,"
SET UCF=$PIECE(C,U,4)
Begin DoDot:3
+7 SET D=$GET(^PRC(441,ITEM,2,VENDOR,0))
if D=""
QUIT
SET F=$PIECE(A,U,3)
SET G=$PIECE(D,U,10)
IF F="P"
IF G=""
SET $PIECE(D,U,10)=UCF
SET ^PRC(441,ITEM,2,VENDOR,0)=D
QUIT
+8 IF F="W"
SET $PIECE(D,U,10)=UCF
SET ^PRC(441,ITEM,2,VENDOR,0)=D
+9 QUIT
End DoDot:3
+10 QUIT
End DoDot:2
WRITE "."
+11 QUIT
End DoDot:1
+12 SET X=0
FOR
SET X=$ORDER(^PRC(441,X))
if X'>0
QUIT
SET D=$GET(^PRC(441,X,3))
SET SKU=$PIECE(D,U,8)
Begin DoDot:1
+13 SET Y=0
FOR
SET Y=$ORDER(^PRC(441,X,2,Y))
if Y'>0
QUIT
SET A=$GET(^PRC(441,X,2,Y,0))
SET B=$PIECE(A,U,8)
SET C=$PIECE(A,U,10)
if C=""
SET $PIECE(A,U,10)=1
SET ^PRC(441,X,2,Y,0)=A
if SKU=""
SET $PIECE(D,U,8)=B
SET ^PRC(441,X,3)=D
+14 QUIT
End DoDot:1
WRITE "."
