ENCTLAB ;(WASH ISC)/RGY-Generic Bar Code Labels ;1-11-90
;;7.0;ENGINEERING;;Aug 17, 1993
;Copy of PRCTLAB ;DH-WASH ISC
SET DIC="^PRCT(446.5,",DIC(0)="QEAM" DO ^DIC GOTO:Y<0 Q1 SET ENCT=+Y
EN ;Entry point, needs ENCT or optional BY, IOP, FR, TO, ENCTCPY, ENCTSR
GOTO:'$DATA(ENCT) Q1 IF '$ORDER(^PRCT(446.5,ENCT,3,0)) WRITE *7," ... Report needs to be compiled!",! GOTO Q1
SET DIC=$SELECT(+$PIECE(^PRCT(446.5,ENCT,0),"^",2):^DIC($PIECE(^(0),"^",2),0,"GL"),1:1),FLDS="S X=""""",L=0,DHD="@" SET:DIC DIC="^PRCT(446.5,",FR=ENCT,TO=ENCT,BY="@NUMBER",ENCTSR=0
IF '$DATA(ENCTCPY) SET X="How many copies of each label do you want ?^1^^^COPY^ENCTMES2^QUX?.N&(QUX>0)&(QUX<1001)" DO ^ENCTQUES SET ENCTCPY=X
GOTO:'ENCTCPY Q1 SET ENCTCPY=+ENCTCPY IF '$DATA(ENCTSR) SET X="Do you want to SEARCH the "_$PIECE(@(DIC_"0)"),"^")_" file before sorting (Y/N)? ^N^^^SP^ENCTMES2" DO ENYN^ENCTQUES GOTO:X="^" Q1 SET ENCTSR=X
SET X=0 FOR Y=1:1 SET X=$ORDER(^PRCT(446.5,+ENCT,3,X)) QUIT:'X SET FLDS(Y)=^(X,0)
IF ENCTSR DO EN^DIS GOTO Q1
DO EN1^DIP
Q1 KILL ENCTSC,ENCT,ENCTX,ENCTCP,ENCTCPY,ENCTSR,ENCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC QUIT
XEC SET X="" XECUTE:$DATA(^PRCT(446.5,+ENCT,4,$PIECE(ENCT,"^",2),0)) ^(0) KILL ENCT WRITE:DUZ(0)="@" X QUIT
SPC ;Call for executing speciality commands
FOR X=0:0 SET X=$ORDER(^PRCT(446.6,+ENCT,$PIECE(ENCT,"^",2),X)) QUIT:'X IF $DATA(^(X,0)),";"'[$EXTRACT(^(0)) WRITE @^(0)
KILL ENCT SET X="" QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENCTLAB 1436 printed Oct 16, 2024@17:53 Page 2
ENCTLAB ;(WASH ISC)/RGY-Generic Bar Code Labels ;1-11-90
+1 ;;7.0;ENGINEERING;;Aug 17, 1993
+2 ;Copy of PRCTLAB ;DH-WASH ISC
+3 SET DIC="^PRCT(446.5,"
SET DIC(0)="QEAM"
DO ^DIC
if Y<0
GOTO Q1
SET ENCT=+Y
EN ;Entry point, needs ENCT or optional BY, IOP, FR, TO, ENCTCPY, ENCTSR
+1 if '$DATA(ENCT)
GOTO Q1
IF '$ORDER(^PRCT(446.5,ENCT,3,0))
WRITE *7," ... Report needs to be compiled!",!
GOTO Q1
+2 SET DIC=$SELECT(+$PIECE(^PRCT(446.5,ENCT,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=ENCT
SET TO=ENCT
SET BY="@NUMBER"
SET ENCTSR=0
+3 IF '$DATA(ENCTCPY)
SET X="How many copies of each label do you want ?^1^^^COPY^ENCTMES2^QUX?.N&(QUX>0)&(QUX<1001)"
DO ^ENCTQUES
SET ENCTCPY=X
+4 if 'ENCTCPY
GOTO Q1
SET ENCTCPY=+ENCTCPY
IF '$DATA(ENCTSR)
SET X="Do you want to SEARCH the "_$PIECE(@(DIC_"0)"),"^")_" file before sorting (Y/N)? ^N^^^SP^ENCTMES2"
DO ENYN^ENCTQUES
if X="^"
GOTO Q1
SET ENCTSR=X
+5 SET X=0
FOR Y=1:1
SET X=$ORDER(^PRCT(446.5,+ENCT,3,X))
if 'X
QUIT
SET FLDS(Y)=^(X,0)
+6 IF ENCTSR
DO EN^DIS
GOTO Q1
+7 DO EN1^DIP
Q1 KILL ENCTSC,ENCT,ENCTX,ENCTCP,ENCTCPY,ENCTSR,ENCTA,IOP,FR,TO,BY,L,DHD,FLDS,DIC
QUIT
XEC SET X=""
if $DATA(^PRCT(446.5,+ENCT,4,$PIECE(ENCT,"^",2),0))
XECUTE ^(0)
KILL ENCT
if DUZ(0)="@"
WRITE X
QUIT
SPC ;Call for executing speciality commands
+1 FOR X=0:0
SET X=$ORDER(^PRCT(446.6,+ENCT,$PIECE(ENCT,"^",2),X))
if 'X
QUIT
IF $DATA(^(X,0))
IF ";"'[$EXTRACT(^(0))
WRITE @^(0)
+2 KILL ENCT
SET X=""
QUIT
