- 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 Mar 13, 2025@21:16:22 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 "."
