PRCHFGRP ;WISC/AKS-Updating of FOOD GROUP field in file 441 ;8-20-92/09:55
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N X,Y,ITMZ,PRCPDESC
ITEM W ! S DIC="^PRC(441,",DIC(0)="AEMQ",DIC("A")="Select Item no.: "
S DIC("S")="I '+$G(^(3))&($P($P(^(0),U,3)/100,""."")=89)"
S DIC("W")="S ITMZ=^PRC(441,+Y,0),PRCPDESC=$P(ITMZ,U,2) D WD^PRCHFGRP"
D ^DIC K DIC,DA I X']""!(X="^") G EXIT
W ! S DR="20//",DIE="^PRC(441,",DA=+Y D ^DIE K DIE,DA,DR
G ITEM
EXIT QUIT
WD S DESC=$E(PRCPDESC,1,30),DESC=DESC_$J("",30-$L(DESC))
W $E(" ",$L(X),5) S ZX=$X+1 W DESC_" NSN: "_$P(ITMZ,U,5) W:$L(PRCPDESC)>30 !,?ZX,$E(PRCPDESC,31,60) K ITMZ,ZX,DESC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFGRP 708 printed Nov 22, 2024@17:17:35 Page 2
PRCHFGRP ;WISC/AKS-Updating of FOOD GROUP field in file 441 ;8-20-92/09:55
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 NEW X,Y,ITMZ,PRCPDESC
ITEM WRITE !
SET DIC="^PRC(441,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select Item no.: "
+1 SET DIC("S")="I '+$G(^(3))&($P($P(^(0),U,3)/100,""."")=89)"
+2 SET DIC("W")="S ITMZ=^PRC(441,+Y,0),PRCPDESC=$P(ITMZ,U,2) D WD^PRCHFGRP"
+3 DO ^DIC
KILL DIC,DA
IF X']""!(X="^")
GOTO EXIT
+4 WRITE !
SET DR="20//"
SET DIE="^PRC(441,"
SET DA=+Y
DO ^DIE
KILL DIE,DA,DR
+5 GOTO ITEM
EXIT QUIT
WD SET DESC=$EXTRACT(PRCPDESC,1,30)
SET DESC=DESC_$JUSTIFY("",30-$LENGTH(DESC))
+1 WRITE $EXTRACT(" ",$LENGTH(X),5)
SET ZX=$X+1
WRITE DESC_" NSN: "_$PIECE(ITMZ,U,5)
if $LENGTH(PRCPDESC)>30
WRITE !,?ZX,$EXTRACT(PRCPDESC,31,60)
KILL ITMZ,ZX,DESC
QUIT
