| 1 | PRCTLAB ;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))
|
|---|
| 5 | EN ;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
|
|---|
| 14 | Q1 KILL PRCTSC,PRCT,PRCTX,PRCTCP,PRCTCPY,PRCTSR,PRCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC,%T,ZTSK QUIT
|
|---|
| 15 | XEC SET X="" XECUTE:$DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0)) ^(0) KILL PRCT WRITE X QUIT
|
|---|
| 16 | SPC ;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
|
|---|
