RTL2 ;MJK/TROY ISC;Routine to print labels; ; 1/30/87 10:08 AM ;
;;v 2.0;Record Tracking;;10/22/91
CMP Q:'$D(^DIC(194.4,RTFMT,0)) S RTROW=$S($P(^(0),"^",2):$P(^(0),"^",2),1:6) K ^DIC(194.4,RTFMT,"E")
F RTI=0:0 S RTI=$O(^DIC(194.4,RTFMT,1,RTI)) Q:RTI'>0 I $D(^(RTI,0)) S ^TMP($J,"FORM",+$P(^(0),"^",2),+$P(^(0),"^",3),$P(^(0),"^",1))=$P(^(0),"^",4,5)
S RTN=1 F RTI=1:1:RTROW S RTFL=1 S:'$D(^TMP($J,"FORM",RTI)) ^DIC(194.4,RTFMT,"E",RTN,0)="W !",RTN=RTN+1 I $D(^(RTI)) F RTCOL=0:0 S RTCOL=$O(^TMP($J,"FORM",RTI,RTCOL)) Q:RTCOL'>0 S %="",%=$O(^(RTCOL,%)) S J=^(%) D STORE
W !!?5,"...format '",$P(^DIC(194.4,RTFMT,0),"^",1),"' has been compiled."
K RTROW,RTI,RTII,RTIV,RTDEF,J,RTITL,RTCOL,RTN,^TMP($J,"FORM") Q
;
STORE S RTIV="DT",RTDEF="" S:$D(^DIC(194.5,+%,0)) RTIV=$P(^(0),"^",5),RTDEF=$P(^(0),"^",3)
S RTITLE=$S(RTIV="RTV(1)":"",$P(J,"^",1)="NONE":"",$P(J,"^",1)]"":$P(J,"^",1),1:RTDEF)
S ^DIC(194.4,RTFMT,"E",RTN,0)="W "_$S(RTFL:"!",1:"")_"?"_(RTCOL-1)_","""_RTITLE_""","_$S(RTIV="RTV(1)":""""_$P(J,"^",2)_"""",1:RTIV) S RTN=RTN+1,RTFL=0
Q
;
TEST S RTEST="",RTNUM=1
W ! S DIC="^DIC(194.4,",DIC("S")="I $P(^(0),U,3)=+RTAPL",DIC("A")="Select Label Format: ",DIC(0)="IAEMQ" D ^DIC K DIC G Q:Y<0 S RTFMT=+Y
D ^%ZIS I 'POP U IO D PRT^RTL1 D ^%ZISC U IO(0)
Q K RTEST,RTNUM,RTFMT,DUOUT
K A,DIC,J,K,POP,RTBC,Y Q
BC ;DIC("S") for print fields multiple of 194.4 (LABEL FORMAT file)
; Z1 = type of label from 194.4
; Z2 = " " " from 194.5 (LABEL PRINT FIELD file)
; Z3 = 1 or 0 depending is Z1 and Z2 are compatible
; AND if the field is a barcode field, that it is
; the ONLY barcode field for the label format
;
S Z1=$P(^DIC(194.4,D0,0),U,4),Z2=$P(^DIC(194.5,+Y,0),U,2),Z3=$S(Z2="a"!(Z1=Z2):1,Z1="q"&(Z2="r"):1,1:0)
I Z3,$P(^DIC(194.5,+Y,0),U,6)="y" F RAI=0:0 S RAI=$O(^DIC(194.4,D0,1,RAI)) Q:'RAI I $D(^(RAI,0)),+Y'=+^(0),$D(^DIC(194.5,+^(0),0)),$P(^(0),U,6)="y" S Z3=0 Q
I Z3
K Z1,Z2,Z3,RAI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTL2 1989 printed Dec 13, 2024@02:33:58 Page 2
RTL2 ;MJK/TROY ISC;Routine to print labels; ; 1/30/87 10:08 AM ;
+1 ;;v 2.0;Record Tracking;;10/22/91
CMP if '$DATA(^DIC(194.4,RTFMT,0))
QUIT
SET RTROW=$SELECT($PIECE(^(0),"^",2):$PIECE(^(0),"^",2),1:6)
KILL ^DIC(194.4,RTFMT,"E")
+1 FOR RTI=0:0
SET RTI=$ORDER(^DIC(194.4,RTFMT,1,RTI))
if RTI'>0
QUIT
IF $DATA(^(RTI,0))
SET ^TMP($JOB,"FORM",+$PIECE(^(0),"^",2),+$PIECE(^(0),"^",3),$PIECE(^(0),"^",1))=$PIECE(^(0),"^",4,5)
+2 SET RTN=1
FOR RTI=1:1:RTROW
SET RTFL=1
if '$DATA(^TMP($JOB,"FORM",RTI))
SET ^DIC(194.4,RTFMT,"E",RTN,0)="W !"
SET RTN=RTN+1
IF $DATA(^(RTI))
FOR RTCOL=0:0
SET RTCOL=$ORDER(^TMP($JOB,"FORM",RTI,RTCOL))
if RTCOL'>0
QUIT
SET %=""
SET %=$ORDER(^(RTCOL,%))
SET J=^(%)
DO STORE
+3 WRITE !!?5,"...format '",$PIECE(^DIC(194.4,RTFMT,0),"^",1),"' has been compiled."
+4 KILL RTROW,RTI,RTII,RTIV,RTDEF,J,RTITL,RTCOL,RTN,^TMP($JOB,"FORM")
QUIT
+5 ;
STORE SET RTIV="DT"
SET RTDEF=""
if $DATA(^DIC(194.5,+%,0))
SET RTIV=$PIECE(^(0),"^",5)
SET RTDEF=$PIECE(^(0),"^",3)
+1 SET RTITLE=$SELECT(RTIV="RTV(1)":"",$PIECE(J,"^",1)="NONE":"",$PIECE(J,"^",1)]"":$PIECE(J,"^",1),1:RTDEF)
+2 SET ^DIC(194.4,RTFMT,"E",RTN,0)="W "_$SELECT(RTFL:"!",1:"")_"?"_(RTCOL-1)_","""_RTITLE_""","_$SELECT(RTIV="RTV(1)":""""_$PIECE(J,"^",2)_"""",1:RTIV)
SET RTN=RTN+1
SET RTFL=0
+3 QUIT
+4 ;
TEST SET RTEST=""
SET RTNUM=1
+1 WRITE !
SET DIC="^DIC(194.4,"
SET DIC("S")="I $P(^(0),U,3)=+RTAPL"
SET DIC("A")="Select Label Format: "
SET DIC(0)="IAEMQ"
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET RTFMT=+Y
+2 DO ^%ZIS
IF 'POP
USE IO
DO PRT^RTL1
DO ^%ZISC
USE IO(0)
Q KILL RTEST,RTNUM,RTFMT,DUOUT
+1 KILL A,DIC,J,K,POP,RTBC,Y
QUIT
BC ;DIC("S") for print fields multiple of 194.4 (LABEL FORMAT file)
+1 ; Z1 = type of label from 194.4
+2 ; Z2 = " " " from 194.5 (LABEL PRINT FIELD file)
+3 ; Z3 = 1 or 0 depending is Z1 and Z2 are compatible
+4 ; AND if the field is a barcode field, that it is
+5 ; the ONLY barcode field for the label format
+6 ;
+7 SET Z1=$PIECE(^DIC(194.4,D0,0),U,4)
SET Z2=$PIECE(^DIC(194.5,+Y,0),U,2)
SET Z3=$SELECT(Z2="a"!(Z1=Z2):1,Z1="q"&(Z2="r"):1,1:0)
+8 IF Z3
IF $PIECE(^DIC(194.5,+Y,0),U,6)="y"
FOR RAI=0:0
SET RAI=$ORDER(^DIC(194.4,D0,1,RAI))
if 'RAI
QUIT
IF $DATA(^(RAI,0))
IF +Y'=+^(0)
IF $DATA(^DIC(194.5,+^(0),0))
IF $PIECE(^(0),U,6)="y"
SET Z3=0
QUIT
+9 IF Z3
+10 KILL Z1,Z2,Z3,RAI
QUIT
