PRCHDRG.m

PRCHDRG ;WISC/AKS-Updating of DRUG TYPE CODE field in file 441 ;3-12-92/10:04

 ;;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)="AMEQ",DIC("A")="Select Item no.: "

 S DIC("S")="I +$P(^(0),U,3)=6505,'+$G(^(3))"

 S DIC("W")="S ITMZ=^PRC(441,+Y,0),PRCPDESC=$P(ITMZ,U,2) D WD^PRCHDRG"

 D ^DIC K DIC,DA I X']""!(X="^") G EXIT

 W ! S DR="22//",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 ---PRCHDRG   697     printed  Apr 09, 2024@21:08:03                                                                                                                                                                                                      Page 2

PRCHDRG   ;WISC/AKS-Updating of DRUG TYPE CODE field in file 441 ;3-12-92/10:04

 +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)="AMEQ"

           SET DIC("A")="Select Item no.: "

 +1        SET DIC("S")="I +$P(^(0),U,3)=6505,'+$G(^(3))"

 +2        SET DIC("W")="S ITMZ=^PRC(441,+Y,0),PRCPDESC=$P(ITMZ,U,2) D WD^PRCHDRG"

 +3        DO ^DIC

           KILL DIC,DA

           IF X']""!(X="^")

               GOTO EXIT

 +4        WRITE !

           SET DR="22//"

           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