PRCTLAB ;WISC@ALTOONA/RGY-GENERIC BARCODE LABEL ;10.21.98
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 SET DIC="^PRCT(446.5,",DIC(0)="QEAM" DO ^DIC GOTO:Y<0 Q1 SET PRCT=+Y,X=$PIECE(^PRCT(446.5,PRCT,0),"^",3) IF X]"" GOTO @($PIECE(X,"-")_"^"_$PIECE(X,"-",2))
EN ;Entry point, needs PRCT or optional BY, IOP, FR, TO, PRCTCPY, PRCTSR
 GOTO:'$DATA(PRCT) Q1 IF '$ORDER(^PRCT(446.5,PRCT,3,0)) WRITE *7," ... Report needs to be compiled!",! GOTO Q1
 SET:$PIECE(^PRCT(446.5,PRCT,0),"^",2) PRCTCPY=1
 SET DIC=$SELECT(+$PIECE(^PRCT(446.5,PRCT,0),"^",2):^DIC($PIECE(^(0),"^",2),0,"GL"),1:1),FLDS="S X=""""",L=0,DHD="@" SET:DIC DIC="^PRCT(446.5,",FR=PRCT,TO=PRCT,BY="@NUMBER",PRCTSR=0
 IF '$DATA(PRCTCPY) SET X="How many copies of each label do you want ?^1^^^COPY^PRCTMES2^QUX?.N&(QUX>0)&(QUX<1001)" DO ^PRCTQUES SET PRCTCPY=X
 GOTO:'PRCTCPY Q1 SET PRCTCPY=+PRCTCPY IF '$DATA(PRCTSR) SET X="Do you want to SEARCH the "_$PIECE(@(DIC_"0)"),"^")_" file before sorting (Y/N)? ^N^^^SP^PRCTMES2" DO ENYN^PRCTQUES GOTO:X="^" Q1 SET PRCTSR=X
 SET X=0 FOR Y=1:1 SET X=$ORDER(^PRCT(446.5,+PRCT,3,X)) QUIT:'X  SET FLDS(Y)=^(X,0)
 IF PRCTSR DO EN^DIS GOTO Q1
 DO EN1^DIP
Q1 KILL PRCTSC,PRCT,PRCTX,PRCTCP,PRCTCPY,PRCTSR,PRCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC,%T,ZTSK QUIT
XEC SET X="" XECUTE:$DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0)) ^(0) KILL PRCT WRITE X QUIT
SPC ;Call for executing specialty commands
 FOR X=0:0 SET X=$ORDER(^PRCT(446.6,+PRCT,$PIECE(PRCT,"^",2),X)) QUIT:'X  IF $DATA(^(X,0)),";"'[$EXTRACT(^(0)) WRITE @^(0)
 KILL PRCT SET X="" QUIT