- RTL1 ;TROY ISC/MJK-Routine to Print Labels ; 5/1/87 11:55 AM ; 4/10/03 3:28pm
- ;;2.0;Record Tracking;**27,35**;10/22/91
- RTQ Q:'$D(^RTV(190.1,RTQ,0)) S RTIFN=RTQ I $D(^RT(+^(0),0)) S X=+$P(^(0),"^",3),T=6,RTMES="W !?3,""...notice for request #"_RTIFN_" has been queued to print on device "",$E(RTION,1,15)",RTNUM=1
- REC I '$D(RTIFN) Q:'$D(^RT(RT,0)) S RTIFN=RT,X=+$P(^(0),"^",3),T=5,RTMES="W !?3,""...label for record #"_RTIFN_" has been queued to print on device "",$E(RTION,1,15)",RTNUM=1
- D FMT,Q:RTFMT K RTMES,RTNUM,RTIFN,RTFMT,T Q
- ;
- FMT S RTFMT=$S('$D(^DIC(195.2,X,0)):"",$D(^DIC(194.4,+$P(^(0),"^",T),0)):$P(^DIC(195.2,X,0),"^",T),1:"") Q
- ;
- PRT K RTBAR,RTQ,RTBC Q:'$D(^DIC(194.4,RTFMT,0)) S T=$P(^(0),"^",4)
- I $D(RTEST) F RTI=0:0 S RTI=$O(^DIC(194.4,RTFMT,1,RTI)) Q:RTI'>0 I $D(^(RTI,0)),$D(^DIC(194.5,+^(0),0)) S @$P(^(0),"^",5)=$P(^(0),"^",4) S:$P(^(0),"^",6)="y" RTBC=$P(^(0),"^",5)
- I '$D(RTEST) D TYPE G EXIT:RT0="" F RTI=0:0 S RTI=$O(^DIC(194.4,RTFMT,1,RTI)) Q:RTI'>0 I $D(^(RTI,0)) S RTJ=+^(0) I $D(^DIC(194.5,RTJ,0)) S:$P(^(0),"^",6)="y" RTBC=$P(^(0),"^",5) I $D(^("E")) X ^("E")
- F RTII=1:1:RTNUM W @IOF F RTI=0:0 S RTI=$O(^DIC(194.4,RTFMT,"E",RTI)) Q:RTI'>0 X ^DIC(194.4,RTFMT,"E",RTI,0)
- ;reverse video
- ;
- ;"bar1,bar0,barx"; flush for intermec RD
- I $D(RTBC) S RTON=$S($D(^%ZIS(2,IOST(0),"BAR1")):^("BAR1"),1:""),RTON=$S(RTON]"":RTON,1:"*0"),RTOFF=$S($D(^("BAR0")):^("BAR0"),1:""),RTOFF=$S(RTOFF]"":RTOFF,1:"*0"),X=@RTBC W @RTON,X,@RTOFF K RTON,RTOFF
- EXIT F RTI=0:0 S RTI=$O(^DIC(194.4,RTFMT,1,RTI)) Q:RTI'>0 I $D(^(RTI,0)),$D(^DIC(194.5,+^(0),0)) K @$P(^(0),"^",5)
- I $D(RTBAR) S T=5,RTIFN=+RTQ,X=+$P(RT0,"^",3) D FMT G PRT:RTFMT
- RD I $D(ION),ION["INTERMEC" F ZQ=0:0 R ZQ:0 Q:'$T
- K ZQ,RTCL,RT0,RTQ,T,RTI,RTII,RTIFN,RTNUM,RTFMT D:'$D(RTTASK) CLOSE^RTUTL Q
- ;
- TYPE I T="r",$D(^RT(RTIFN,0)) D NOW^%DTC S $P(^(0),"^",8)=%,RT0=^(0),RTCL=$S($D(^RT(RTIFN,"CL")):^("CL"),1:"") Q
- I T="q",$D(^RTV(190.1,RTIFN,0)),$P(^(0),"^",6)'="x" D NOW^%DTC S $P(^(0),"^",13)=%,RTQ=^(0),RT0=$S($D(^RT(+RTQ,0)):^(0),1:0),RTCL=$S($D(^RT(+RTQ,"CL")):^("CL"),1:"") S:$S($P(RT0,"^",8):0,1:$D(^RTV(195.9,"AC",ION))>0) RTBAR="" Q
- I T="b",$D(^RTV(195.9,RTIFN,0)) S RT0=^(0) Q
- S RT0="" Q
- ;
- ;
- Q I $S('$D(RTION):1,RTION']"":1,'$D(^%ZIS(1,"B",RTION)):1,'$D(^%ZIS(1,+$O(^(RTION,0)),0)):1,1:0) Q:$D(RTBKGRD) D ZIS Q:POP S RTION=ION,RTA=$O(^%ZIS(1,"B",ION,0)) N RTERR D CHKDEV G Q:RTERR I (^%ZIS(1,RTA,"TYPE")="VTRM") D ER G Q
- S RTVAR="RTIFN^RTNUM^RTFMT",RTVAL=RTIFN_"^"_RTNUM_"^"_RTFMT,RTW=$H
- X ^%ZOSF("UCI") S ZTRTN="DQ^RTL1",ZTUCI=Y,ZTDTH=$H,ZTSAVE("RTVAR")="",ZTSAVE("RTVAL")="" S:$D(DUZ(0)) ZTSAVE("DUZ(0)")=""
- ;
- S ZTDESC="Record Tracking Label Print"
- I '$D(RTTASK) S RTHG=$E(RTION,$L(RTION)-5,99),RTION=$S(RTHG'["RTHG":RTION,1:$E(RTION,1,$L(RTION)-1)_(1+($S($D(RTE):$S(RTE[";DPT(":+$P(^DPT(+RTE,0),"^",9)#2,1:+RTE#2),1:0)))) K RTHG
- S ZTIO=RTION
- D ^%ZTLOAD
- D HOME^%ZIS ;returns io to home device
- X:$D(RTMES)&('$D(RTBKGRD))&('$D(RTIRE)) RTMES H:$D(RTMES) 1 K RTW,RTVAR,RTVAL,ZTSK Q
- ;
- DQ S IO(0)=IO
- F I=1:1 Q:$P(RTVAR,"^",I)']"" S @($P(RTVAR,"^",I))=$P(RTVAL,"^",I)
- S U="^" S X="T",%DT="" D ^%DT S DT=Y G PRT
- Q
- ;
- ER W !!,*7,"You can not queue to a virtual terminal, try again."
- S RTION=""
- Q
- ;
- ZIS S %ZIS("A")="Select Label Device: ",%ZIS="NQ" D ^%ZIS K %ZIS,IO("Q")
- Q
- CHKDEV ; check that device can be queued to
- N RTDEV,RTSUB
- S RTERR=0
- S RTDEV=$G(^%ZIS(1,RTA,0))
- I $P(RTDEV,U,12)=2 S RTERR=1
- I $P(RTDEV,U)["SLAVE" S RTERR=1
- S RTSUB=+$G(^%ZIS(1,RTA,"SUBTYPE"))
- I RTSUB S RTSUB=$G(^%ZIS(2,RTSUB,0),U)
- I RTSUB["SLAVE" S RTERR=1
- I RTERR S RTION="" W !!,*7,"You cannot queue to this device, try again."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTL1 3689 printed Feb 19, 2025@00:00:28 Page 2
- RTL1 ;TROY ISC/MJK-Routine to Print Labels ; 5/1/87 11:55 AM ; 4/10/03 3:28pm
- +1 ;;2.0;Record Tracking;**27,35**;10/22/91
- RTQ if '$DATA(^RTV(190.1,RTQ,0))
- QUIT
- SET RTIFN=RTQ
- IF $DATA(^RT(+^(0),0))
- SET X=+$PIECE(^(0),"^",3)
- SET T=6
- SET RTMES="W !?3,""...notice for request #"_RTIFN_" has been queued to print on device "",$E(RTION,1,15)"
- SET RTNUM=1
- REC IF '$DATA(RTIFN)
- if '$DATA(^RT(RT,0))
- QUIT
- SET RTIFN=RT
- SET X=+$PIECE(^(0),"^",3)
- SET T=5
- SET RTMES="W !?3,""...label for record #"_RTIFN_" has been queued to print on device "",$E(RTION,1,15)"
- SET RTNUM=1
- +1 DO FMT
- if RTFMT
- DO Q
- KILL RTMES,RTNUM,RTIFN,RTFMT,T
- QUIT
- +2 ;
- FMT SET RTFMT=$SELECT('$DATA(^DIC(195.2,X,0)):"",$DATA(^DIC(194.4,+$PIECE(^(0),"^",T),0)):$PIECE(^DIC(195.2,X,0),"^",T),1:"")
- QUIT
- +1 ;
- PRT KILL RTBAR,RTQ,RTBC
- if '$DATA(^DIC(194.4,RTFMT,0))
- QUIT
- SET T=$PIECE(^(0),"^",4)
- +1 IF $DATA(RTEST)
- FOR RTI=0:0
- SET RTI=$ORDER(^DIC(194.4,RTFMT,1,RTI))
- if RTI'>0
- QUIT
- IF $DATA(^(RTI,0))
- IF $DATA(^DIC(194.5,+^(0),0))
- SET @$PIECE(^(0),"^",5)=$PIECE(^(0),"^",4)
- if $PIECE(^(0),"^",6)="y"
- SET RTBC=$PIECE(^(0),"^",5)
- +2 IF '$DATA(RTEST)
- DO TYPE
- if RT0=""
- GOTO EXIT
- FOR RTI=0:0
- SET RTI=$ORDER(^DIC(194.4,RTFMT,1,RTI))
- if RTI'>0
- QUIT
- IF $DATA(^(RTI,0))
- SET RTJ=+^(0)
- IF $DATA(^DIC(194.5,RTJ,0))
- if $PIECE(^(0),"^",6)="y"
- SET RTBC=$PIECE(^(0),"^",5)
- IF $DATA(^("E"))
- XECUTE ^("E")
- +3 FOR RTII=1:1:RTNUM
- WRITE @IOF
- FOR RTI=0:0
- SET RTI=$ORDER(^DIC(194.4,RTFMT,"E",RTI))
- if RTI'>0
- QUIT
- XECUTE ^DIC(194.4,RTFMT,"E",RTI,0)
- +4 ;reverse video
- +5 ;
- +6 ;"bar1,bar0,barx"; flush for intermec RD
- +7 IF $DATA(RTBC)
- SET RTON=$SELECT($DATA(^%ZIS(2,IOST(0),"BAR1")):^("BAR1"),1:"")
- SET RTON=$SELECT(RTON]"":RTON,1:"*0")
- SET RTOFF=$SELECT($DATA(^("BAR0")):^("BAR0"),1:"")
- SET RTOFF=$SELECT(RTOFF]"":RTOFF,1:"*0")
- SET X=@RTBC
- WRITE @RTON,X,@RTOFF
- KILL RTON,RTOFF
- EXIT FOR RTI=0:0
- SET RTI=$ORDER(^DIC(194.4,RTFMT,1,RTI))
- if RTI'>0
- QUIT
- IF $DATA(^(RTI,0))
- IF $DATA(^DIC(194.5,+^(0),0))
- KILL @$PIECE(^(0),"^",5)
- +1 IF $DATA(RTBAR)
- SET T=5
- SET RTIFN=+RTQ
- SET X=+$PIECE(RT0,"^",3)
- DO FMT
- if RTFMT
- GOTO PRT
- RD IF $DATA(ION)
- IF ION["INTERMEC"
- FOR ZQ=0:0
- READ ZQ:0
- if '$TEST
- QUIT
- +1 KILL ZQ,RTCL,RT0,RTQ,T,RTI,RTII,RTIFN,RTNUM,RTFMT
- if '$DATA(RTTASK)
- DO CLOSE^RTUTL
- QUIT
- +2 ;
- TYPE IF T="r"
- IF $DATA(^RT(RTIFN,0))
- DO NOW^%DTC
- SET $PIECE(^(0),"^",8)=%
- SET RT0=^(0)
- SET RTCL=$SELECT($DATA(^RT(RTIFN,"CL")):^("CL"),1:"")
- QUIT
- +1 IF T="q"
- IF $DATA(^RTV(190.1,RTIFN,0))
- IF $PIECE(^(0),"^",6)'="x"
- DO NOW^%DTC
- SET $PIECE(^(0),"^",13)=%
- SET RTQ=^(0)
- SET RT0=$SELECT($DATA(^RT(+RTQ,0)):^(0),1:0)
- SET RTCL=$SELECT($DATA(^RT(+RTQ,"CL")):^("CL"),1:"")
- if $SELECT($PIECE(RT0,"^",8)
- SET RTBAR=""
- QUIT
- +2 IF T="b"
- IF $DATA(^RTV(195.9,RTIFN,0))
- SET RT0=^(0)
- QUIT
- +3 SET RT0=""
- QUIT
- +4 ;
- +5 ;
- Q IF $SELECT('$DATA(RTION):1,RTION']"":1,'$DATA(^%ZIS(1,"B",RTION)):1,'$DATA(^%ZIS(1,+$ORDER(^(RTION,0)),0)):1,1:0)
- if $DATA(RTBKGRD)
- QUIT
- DO ZIS
- if POP
- QUIT
- SET RTION=ION
- SET RTA=$ORDER(^%ZIS(1,"B",ION,0))
- NEW RTERR
- DO CHKDEV
- if RTERR
- GOTO Q
- IF (^%ZIS(1,RTA,"TYPE")="VTRM")
- DO ER
- GOTO Q
- +1 SET RTVAR="RTIFN^RTNUM^RTFMT"
- SET RTVAL=RTIFN_"^"_RTNUM_"^"_RTFMT
- SET RTW=$HOROLOG
- +2 XECUTE ^%ZOSF("UCI")
- SET ZTRTN="DQ^RTL1"
- SET ZTUCI=Y
- SET ZTDTH=$HOROLOG
- SET ZTSAVE("RTVAR")=""
- SET ZTSAVE("RTVAL")=""
- if $DATA(DUZ(0))
- SET ZTSAVE("DUZ(0)")=""
- +3 ;
- +4 SET ZTDESC="Record Tracking Label Print"
- +5 IF '$DATA(RTTASK)
- SET RTHG=$EXTRACT(RTION,$LENGTH(RTION)-5,99)
- SET RTION=$SELECT(RTHG'["RTHG":RTION,1:$EXTRACT(RTION,1,$LENGTH(RTION)-1)_(1+($SELECT($DATA(RTE):$SELECT(RTE[";DPT(":+$PIECE(^DPT(+RTE,0),"^",9)#2,1:+RTE#2),1:0))))
- KILL RTHG
- +6 SET ZTIO=RTION
- +7 DO ^%ZTLOAD
- +8 ;returns io to home device
- DO HOME^%ZIS
- +9 if $DATA(RTMES)&('$DATA(RTBKGRD))&('$DATA(RTIRE))
- XECUTE RTMES
- if $DATA(RTMES)
- HANG 1
- KILL RTW,RTVAR,RTVAL,ZTSK
- QUIT
- +10 ;
- DQ SET IO(0)=IO
- +1 FOR I=1:1
- if $PIECE(RTVAR,"^",I)']""
- QUIT
- SET @($PIECE(RTVAR,"^",I))=$PIECE(RTVAL,"^",I)
- +2 SET U="^"
- SET X="T"
- SET %DT=""
- DO ^%DT
- SET DT=Y
- GOTO PRT
- +3 QUIT
- +4 ;
- ER WRITE !!,*7,"You can not queue to a virtual terminal, try again."
- +1 SET RTION=""
- +2 QUIT
- +3 ;
- ZIS SET %ZIS("A")="Select Label Device: "
- SET %ZIS="NQ"
- DO ^%ZIS
- KILL %ZIS,IO("Q")
- +1 QUIT
- CHKDEV ; check that device can be queued to
- +1 NEW RTDEV,RTSUB
- +2 SET RTERR=0
- +3 SET RTDEV=$GET(^%ZIS(1,RTA,0))
- +4 IF $PIECE(RTDEV,U,12)=2
- SET RTERR=1
- +5 IF $PIECE(RTDEV,U)["SLAVE"
- SET RTERR=1
- +6 SET RTSUB=+$GET(^%ZIS(1,RTA,"SUBTYPE"))
- +7 IF RTSUB
- SET RTSUB=$GET(^%ZIS(2,RTSUB,0),U)
- +8 IF RTSUB["SLAVE"
- SET RTERR=1
- +9 IF RTERR
- SET RTION=""
- WRITE !!,*7,"You cannot queue to this device, try again."
- +10 QUIT