RMPRPIYZ ;HINES CIO/ODJ - Bar Code Print all label ;10/8/02 13:11
;;3.0;PROSTHETICS;**61,108**;Feb 09, 1996
Q
;
PB ;***** PB - Print ALL Bar Code labels
;
;
;***** STN - prompt for Site/Station
STN ;S RMPROVAL=$G(RMPRSTN("IEN"))
W @IOF S RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
I RMPRERR G PBX
I RMPREXC'="" G PBX
S RS=RMPRSTN("IEN") K RMPR1,RMPR11
;
LOC ; askk for location
;
S RMPRERR=$$LOCNM^RMPRPIY2(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
I RMPREXC="T"!(RMPREXC="^") G PBX
I RMPREXC="P" G STN
S RL=RMPR5("IEN") K RMPR1
;
;***** PRINT - print bar code labels
; requires RMPRNLAB (number of labels) and
; RMPRBCP (bar code printer name) to be set
; RMPRBARC (bar code to print)
; RMPRIOP (the device to open)
PRINT ;I '$D(RMPRBCP) G PRINTX
;allows queing of bar code labels
SELD S %ZIS("A")="Select Bar Code Printer: "
S %ZIS="QM" K IOP W ! D ^%ZIS G:POP PRINTX
I $G(IOST)'["P-ZEBRA" D
. W !!,"** WARNING - This is NOT a Zebra Bar Code Printer!!",!!
I '$D(IO("Q")) U IO G PNOW
K IO("Q") S ZTDESC="PRINT BAR CODE LABELS",ZTRTN="PNOW^RMPRPIYZ"
S ZTIO=ION,ZTSAVE("RS")="",ZTSAVE("RL")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 2 G PRINTC
;
PNOW ;jump here if not queued.
;
;
LOOP ;loop 661.7 for all items in a location.
F RI=0:0 S RI=$O(^RMPR(661.7,"C",RL,RI)) Q:RI'>0 S RMDAT=$G(^RMPR(661.7,RI,0)) S RMSTN=$P(RMDAT,U,5) I RMSTN=RS D PROC
;exit/done printing bar code labels
G PRINTC
;
PROC ;process bar code for printing.
S (RMPRNLAB,RME)=0,RMPR11("DESCRIPTION")=""
S RMPR6("VENDOR")="",RMLOCNA=""
K RMPR7I,RM441,RM661
S RMPR7("IEN")=RI,RMPR7("HCPCS")=$P(RMDAT,U,1)
S RMPR7("ITEM")=$P(RMDAT,U,4),RH=$P(RMDAT,U,1)
S RD=$P(RMDAT,U,2)
S (RMPR7("LOCATION"),RMLOC)=$P(RMDAT,U,6)
S RMPR7("VALUE")=$P(RMDAT,U,8),RMPR7("QUANTITY")=$P(RMDAT,U,7)
I $G(RMLOC),$D(^RMPR(661.5,RMLOC,0)) D
.S RMLOCNA=$P(^RMPR(661.5,RMLOC,0),U,1)
;
ITEM ;get 661.11 record
S RMPR11("IEN")=$O(^RMPR(661.11,"ASHI",RS,RH,RMPR7("ITEM"),0))
S RME=$$GET^RMPRPIX1(.RMPR11)
I RME=1 Q
;
VEND ;get vendor from 661.6.
S RMV="",RMPR6("VENDOR")="",RMPR11("ITEM MSTER")=""
F K=0:0 S K=$O(^RMPR(661.6,"C",RD,K)) Q:K'>0 S RM6=$G(^RMPR(661.6,K,0)) D
.Q:RH'=$P(RM6,U,1)
.I (RH=$P(RM6,U,1)),(RMLOC=$P(RM6,U,14)) S RMV=$P(RM6,U,12)
.S:$G(RMV) RMPR6("VENDOR")=$$GETVEN^RMPRPIU0(RMV)
;
;external format of items at #661.7
S RME=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
I RME=1 Q
;
;set variables for printing bar code.
S RMPRBARC=RMPR7I("HCPCS")_"-"_$P(RMPR7I("DATE&TIME"),".",1)_$P(RMPR7I("DATE&TIME"),".",2)
S RMPRITXT("DATE")=$E(RMPR7I("DATE&TIME"),4,5)_"/"_$E(RMPR7I("DATE&TIME"),6,7)_"/"_(1700+$E(RMPR7I("DATE&TIME"),1,3))
S RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
S RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
S RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
S RMPRITXT("UNIT PRICE")=+$J(RMPR7("VALUE")/RMPR7("QUANTITY"),0,2)
S RMPRITXT("VENDOR")=RMPR6("VENDOR")
S RMPRITXT("LOCATION")=RMLOCNA
S RMPRNLAB=RMPR7("QUANTITY")
;call bar code routine
D ZPLII^RMPRPI11(RMPRBARC,.RMPRITXT,RMPRNLAB)
Q
;
PRINTC ;
D ^%ZISC K IONOFF
;
PBX D KILL^XUSCLEAN
PRINTX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYZ 3248 printed Mar 13, 2025@21:42:15 Page 2
RMPRPIYZ ;HINES CIO/ODJ - Bar Code Print all label ;10/8/02 13:11
+1 ;;3.0;PROSTHETICS;**61,108**;Feb 09, 1996
+2 QUIT
+3 ;
PB ;***** PB - Print ALL Bar Code labels
+1 ;
+2 ;
+3 ;***** STN - prompt for Site/Station
STN ;S RMPROVAL=$G(RMPRSTN("IEN"))
+1 WRITE @IOF
SET RMPRERR=$$STN^RMPRPIY1(.RMPRSTN,.RMPREXC)
+2 IF RMPRERR
GOTO PBX
+3 IF RMPREXC'=""
GOTO PBX
+4 SET RS=RMPRSTN("IEN")
KILL RMPR1,RMPR11
+5 ;
LOC ; askk for location
+1 ;
+2 SET RMPRERR=$$LOCNM^RMPRPIY2(RMPRSTN("IEN"),.RMPR5,.RMPREXC)
+3 IF RMPREXC="T"!(RMPREXC="^")
GOTO PBX
+4 IF RMPREXC="P"
GOTO STN
+5 SET RL=RMPR5("IEN")
KILL RMPR1
+6 ;
+7 ;***** PRINT - print bar code labels
+8 ; requires RMPRNLAB (number of labels) and
+9 ; RMPRBCP (bar code printer name) to be set
+10 ; RMPRBARC (bar code to print)
+11 ; RMPRIOP (the device to open)
PRINT ;I '$D(RMPRBCP) G PRINTX
+1 ;allows queing of bar code labels
SELD SET %ZIS("A")="Select Bar Code Printer: "
+1 SET %ZIS="QM"
KILL IOP
WRITE !
DO ^%ZIS
if POP
GOTO PRINTX
+2 IF $GET(IOST)'["P-ZEBRA"
Begin DoDot:1
+3 WRITE !!,"** WARNING - This is NOT a Zebra Bar Code Printer!!",!!
End DoDot:1
+4 IF '$DATA(IO("Q"))
USE IO
GOTO PNOW
+5 KILL IO("Q")
SET ZTDESC="PRINT BAR CODE LABELS"
SET ZTRTN="PNOW^RMPRPIYZ"
+6 SET ZTIO=ION
SET ZTSAVE("RS")=""
SET ZTSAVE("RL")=""
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!"
HANG 2
GOTO PRINTC
+8 ;
PNOW ;jump here if not queued.
+1 ;
+2 ;
LOOP ;loop 661.7 for all items in a location.
+1 FOR RI=0:0
SET RI=$ORDER(^RMPR(661.7,"C",RL,RI))
if RI'>0
QUIT
SET RMDAT=$GET(^RMPR(661.7,RI,0))
SET RMSTN=$PIECE(RMDAT,U,5)
IF RMSTN=RS
DO PROC
+2 ;exit/done printing bar code labels
+3 GOTO PRINTC
+4 ;
PROC ;process bar code for printing.
+1 SET (RMPRNLAB,RME)=0
SET RMPR11("DESCRIPTION")=""
+2 SET RMPR6("VENDOR")=""
SET RMLOCNA=""
+3 KILL RMPR7I,RM441,RM661
+4 SET RMPR7("IEN")=RI
SET RMPR7("HCPCS")=$PIECE(RMDAT,U,1)
+5 SET RMPR7("ITEM")=$PIECE(RMDAT,U,4)
SET RH=$PIECE(RMDAT,U,1)
+6 SET RD=$PIECE(RMDAT,U,2)
+7 SET (RMPR7("LOCATION"),RMLOC)=$PIECE(RMDAT,U,6)
+8 SET RMPR7("VALUE")=$PIECE(RMDAT,U,8)
SET RMPR7("QUANTITY")=$PIECE(RMDAT,U,7)
+9 IF $GET(RMLOC)
IF $DATA(^RMPR(661.5,RMLOC,0))
Begin DoDot:1
+10 SET RMLOCNA=$PIECE(^RMPR(661.5,RMLOC,0),U,1)
End DoDot:1
+11 ;
ITEM ;get 661.11 record
+1 SET RMPR11("IEN")=$ORDER(^RMPR(661.11,"ASHI",RS,RH,RMPR7("ITEM"),0))
+2 SET RME=$$GET^RMPRPIX1(.RMPR11)
+3 IF RME=1
QUIT
+4 ;
VEND ;get vendor from 661.6.
+1 SET RMV=""
SET RMPR6("VENDOR")=""
SET RMPR11("ITEM MSTER")=""
+2 FOR K=0:0
SET K=$ORDER(^RMPR(661.6,"C",RD,K))
if K'>0
QUIT
SET RM6=$GET(^RMPR(661.6,K,0))
Begin DoDot:1
+3 if RH'=$PIECE(RM6,U,1)
QUIT
+4 IF (RH=$PIECE(RM6,U,1))
IF (RMLOC=$PIECE(RM6,U,14))
SET RMV=$PIECE(RM6,U,12)
+5 if $GET(RMV)
SET RMPR6("VENDOR")=$$GETVEN^RMPRPIU0(RMV)
End DoDot:1
+6 ;
+7 ;external format of items at #661.7
+8 SET RME=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I)
+9 IF RME=1
QUIT
+10 ;
+11 ;set variables for printing bar code.
+12 SET RMPRBARC=RMPR7I("HCPCS")_"-"_$PIECE(RMPR7I("DATE&TIME"),".",1)_$PIECE(RMPR7I("DATE&TIME"),".",2)
+13 SET RMPRITXT("DATE")=$EXTRACT(RMPR7I("DATE&TIME"),4,5)_"/"_$EXTRACT(RMPR7I("DATE&TIME"),6,7)_"/"_(1700+$EXTRACT(RMPR7I("DATE&TIME"),1,3))
+14 SET RMPRITXT("ITEM")=RMPR11("HCPCS-ITEM")
+15 SET RMPRITXT("MASTER DESC")=RMPR11("ITEM MASTER")
+16 SET RMPRITXT("ITEM DESC")=RMPR11("DESCRIPTION")
+17 SET RMPRITXT("UNIT PRICE")=+$JUSTIFY(RMPR7("VALUE")/RMPR7("QUANTITY"),0,2)
+18 SET RMPRITXT("VENDOR")=RMPR6("VENDOR")
+19 SET RMPRITXT("LOCATION")=RMLOCNA
+20 SET RMPRNLAB=RMPR7("QUANTITY")
+21 ;call bar code routine
+22 DO ZPLII^RMPRPI11(RMPRBARC,.RMPRITXT,RMPRNLAB)
+23 QUIT
+24 ;
PRINTC ;
+1 DO ^%ZISC
KILL IONOFF
+2 ;
PBX DO KILL^XUSCLEAN
PRINTX QUIT
