- 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 ---[H[J[2J[HPRCHDRG 697 printed Feb 18, 2025@23:33:14 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