source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCTLAB.m@ 772

Last change on this file since 772 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.5 KB
Line 
1PRCTLAB ;WISC@ALTOONA/RGY-GENERIC BARCODE LABEL ;10.21.98
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 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))
5EN ;Entry point, needs PRCT or optional BY, IOP, FR, TO, PRCTCPY, PRCTSR
6 GOTO:'$DATA(PRCT) Q1 IF '$ORDER(^PRCT(446.5,PRCT,3,0)) WRITE *7," ... Report needs to be compiled!",! GOTO Q1
7 SET:$PIECE(^PRCT(446.5,PRCT,0),"^",2) PRCTCPY=1
8 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
9 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
10 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
11 SET X=0 FOR Y=1:1 SET X=$ORDER(^PRCT(446.5,+PRCT,3,X)) QUIT:'X SET FLDS(Y)=^(X,0)
12 IF PRCTSR DO EN^DIS GOTO Q1
13 DO EN1^DIP
14Q1 KILL PRCTSC,PRCT,PRCTX,PRCTCP,PRCTCPY,PRCTSR,PRCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC,%T,ZTSK QUIT
15XEC SET X="" XECUTE:$DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0)) ^(0) KILL PRCT WRITE X QUIT
16SPC ;Call for executing specialty commands
17 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)
18 KILL PRCT SET X="" QUIT
Note: See TracBrowser for help on using the repository browser.