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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCTLAB 1600 printed Dec 13, 2024@02:19:18 Page 2
PRCTLAB ;WISC@ALTOONA/RGY-GENERIC BARCODE LABEL ;10.21.98
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DIC="^PRCT(446.5,"
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
GOTO Q1
SET PRCT=+Y
SET 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
+1 if '$DATA(PRCT)
GOTO Q1
IF '$ORDER(^PRCT(446.5,PRCT,3,0))
WRITE *7," ... Report needs to be compiled!",!
GOTO Q1
+2 if $PIECE(^PRCT(446.5,PRCT,0),"^",2)
SET PRCTCPY=1
+3 SET DIC=$SELECT(+$PIECE(^PRCT(446.5,PRCT,0),"^",2):^DIC($PIECE(^(0),"^",2),0,"GL"),1:1)
SET FLDS="S X="""""
SET L=0
SET DHD="@"
if DIC
SET DIC="^PRCT(446.5,"
SET FR=PRCT
SET TO=PRCT
SET BY="@NUMBER"
SET PRCTSR=0
+4 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
+5 if 'PRCTCPY
GOTO 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
if X="^"
GOTO Q1
SET PRCTSR=X
+6 SET X=0
FOR Y=1:1
SET X=$ORDER(^PRCT(446.5,+PRCT,3,X))
if 'X
QUIT
SET FLDS(Y)=^(X,0)
+7 IF PRCTSR
DO EN^DIS
GOTO Q1
+8 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=""
if $DATA(^PRCT(446.5,+PRCT,4,$PIECE(PRCT,"^",2),0))
XECUTE ^(0)
KILL PRCT
WRITE X
QUIT
SPC ;Call for executing specialty commands
+1 FOR X=0:0
SET X=$ORDER(^PRCT(446.6,+PRCT,$PIECE(PRCT,"^",2),X))
if 'X
QUIT
IF $DATA(^(X,0))
IF ";"'[$EXTRACT(^(0))
WRITE @^(0)
+2 KILL PRCT
SET X=""
QUIT
