PSBOBZ ;BIRMINGHAM/TTH-BAR CODE LABELS (MAIN) ;8/17/21 12:43
;;3.0;BAR CODE MED ADMIN;**2,70,81,106,131**;Mar 2004;Build 11
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference/IA
; ^%ZIS(2/3435
; File 50/221
;
;*70 - 1459: Adding clinic to BL and BZ chui labels.
;*106- add Hazardous to Handle & Dispose alert text
;
;*131 - Replaced patch 106 changes in PRINT section with suggestions made by KCF
EN ;
N PSBI,PSBIENS,PSBQTY,PSBDOSE,PSBDRUG,PSBNAME,PSBNODE3,PSBWARD,PSBLOT,PSBBAR,PSBTLE,SL
N PSBEXP,PSBFD,PSBMFG,PSBCB,PSBFB,PSBFCB,PSBCNT,PSBANS,PSBORD,PSBPRE,PSBX,PSBY,PSBSYM,TEXT,PSBCLIN ;[*70-1459]
N PSBDD,PSBHZ,PSBHAZH,PSBHAZD,HAZTEXT ;*106
;
N PSBXX,PSBYY,PSBCODE
S PSBXX=0 F S PSBXX=$O(^%ZIS(2,IOST(0),55,PSBXX)) Q:'PSBXX S PSBYY=$G(^(PSBXX,0)) I PSBYY]"" S PSBX=$P(PSBYY,"^"),PSBY=^(1),PSBCODE(PSBX)=PSBY
;
;The PSBRPT variable and PSBRPT(.3) array are set in the PSBO routine. It is the internal
;entry number from the BCMA REPORT REQUEST file (#53.69). This entry is created
;when the user submits the completed ScreenMan form from the Label Print option.
;
;
S PSBIENS=PSBRPT_","
S PSBBAR=$P($P($G(PSBRPT(.3)),U,1),"~",2)
S PSBPRE=$$GET^XPAR("DIV","PSB DEFAULT BARCODE PREFIX")
S:PSBPRE]"" PSBBAR=PSBPRE_$S(PSBPRE?1.N:"-",1:"")_PSBBAR
S PSBDRUG=$P($P($G(PSBRPT(.3)),U,1),"~",1)
S PSBQTY=+$P($G(PSBRPT(.3)),U,5)
S:PSBQTY PSBDRUG=PSBDRUG_" (Qty: "_PSBQTY_")"
I PSBQTY=0 S PSBDRUG=PSBDRUG_" (Qty: )"
S PSBDOSE=$P($G(PSBRPT(.3)),U,9)
I PSBDOSE]"" S PSBDOSE="Dose:"_PSBDOSE
I PSBDOSE="" S PSBDOSE="Dose:"
S PSBNAME=$$GET1^DIQ(53.69,PSBIENS,.12)
I PSBNAME]"" S PSBNAME=PSBNAME_" ("_$S(DUZ("AG")="I":$$HRN^AUPNPAT($P($G(^PSB(53.69,+PSBIENS,.1)),U,2),$P(^(0),U,4)),1:$E($$GET1^DIQ(53.69,PSBIENS,.121),6,9))_")" ;add code for IHS, PSB*3*81
I PSBNAME="" S PSBNAME="Patient:"
S PSBWARD=$$GET1^DIQ(53.69,PSBIENS,.122)
S PSBCLIN=$$GET1^DIQ(53.69,PSBIENS,5) ;[*70-1459]
I PSBWARD]"" S PSBWARD="Ward: "_PSBWARD
I PSBWARD="" S PSBWARD="Ward: "
I PSBCLIN]"" S PSBWARD="Clinic: "_PSBCLIN ;[*70-1459]
S PSBLOT=$P($G(PSBRPT(.3)),U,2)
I PSBLOT]"" S PSBLOT="Lot: "_PSBLOT
I PSBLOT="" S PSBLOT="Lot: "
S PSBFD=$P($G(PSBRPT(.3)),U,3)
S PSBEXP=$$FMTE^XLFDT(PSBFD,5)
I PSBEXP]"" S PSBEXP="Exp: "_PSBEXP
I PSBEXP="" S PSBEXP="Exp: "
S PSBMFG=$P($G(PSBRPT(.3)),U,4)
I PSBMFG]"" S PSBMFG="Mfg: "_PSBMFG
I PSBMFG="" S PSBMFG="Mfg: "
S PSBFB=$P($G(PSBRPT(.3)),U,6) I PSBFB="" S PSBFB="_____"
S PSBCB=$P($G(PSBRPT(.3)),U,7) I PSBCB="" S PSBCB="_____"
S PSBFCB=PSBFB_"/"_PSBCB
; get HAZ drug info *106
S PSBDD=$$GET1^DIQ(53.69,PSBIENS,.31,"I"),PSBHZ=$$HAZ^PSSUTIL($P(PSBDD,"~",2))
S PSBHAZH=$S($P(PSBHZ,U):"<<HAZ Handle>>",1:""),PSBHAZD=$S($P(PSBHZ,U,2):"<<HAZ Dispose>>",1:"")
S HAZTEXT=""
I $L(PSBHAZH)=0 D
. I $L(PSBHAZD)>0 S HAZTEXT=PSBHAZD
I $L(PSBHAZH)>0 D
. I $L(PSBHAZD)=0 S HAZTEXT=PSBHAZH
. I $L(PSBHAZD)>0 S HAZTEXT="<<HAZ Handle & HAZ Dispose>>"
F PSBCNT=1:1:+$P(PSBRPT(.3),U,8) D LABEL
D CLEAN^PSBVT
Q
;
LABEL ;Get Barcode Label Type
;Barcode Type
S PSBSYM=$$GET^XPAR("DIV","PSB DEFAULT BARCODE FORMAT",,"E")
;
INIT ;Initialize barcode printer
I $D(PSBCODE("FI")) X PSBCODE("FI")
I $D(PSBCODE("FI1")) X PSBCODE("FI1")
I $D(PSBCODE("FI2")) X PSBCODE("FI2")
;
;Additional format settings
I PSBSYM]"",$D(PSBCODE("SBF")) X PSBCODE("SBF")
I PSBSYM="",$D(PSBCODE("EBF")) X PSBCODE("EBF")
;
D START ;execute control codes to start label
D PRINT ;execute control codes to print label
;
;Print Barcode Strip
;If barcode type is defined.
;I PSBSYM]"",$D(PSBCODE("SB")) S TEXT=PSBBAR D BCSTRIP ;106
I PSBSYM]"",$D(PSBCODE("SB")) S TEXT=PSBBAR X PSBCODE("SB") ;131 Restoring 2018 code
;If barcode type is not defined.
;I PSBSYM="",$D(PSBCODE("SB")) S TEXT="*NO BARCODE TYPE*" D BCSTRIP ;106
I PSBSYM="",$D(PSBCODE("SB")) S TEXT="*NO BARCODE TYPE*" X PSBCODE("SB") ;131 Restoring 2018 code
;
END ; Close Label or End of Label
I $G(PSBCODE("EL"))]"" X PSBCODE("EL")
H 2
Q
;
START ;Start Label Print Process
I $G(PSBCODE("SL"))]"" X PSBCODE("SL")
Q
;
PRINT ;Print barcode label
;
I PSBDRUG]"" S PSBTLE="PSBDRUG",TEXT="Drug: "_PSBDRUG D PROCESS
I PSBDOSE]"" S PSBTLE="PSBDOSE",TEXT=PSBDOSE D PROCESS
I PSBNAME]"" S PSBTLE="PSBNAME",TEXT=PSBNAME D PROCESS
I PSBWARD]"" S PSBTLE="PSBWARD",TEXT=PSBWARD D PROCESS
I PSBLOT]"" S PSBTLE="PSBLOT",TEXT=PSBLOT D PROCESS
I PSBEXP]"" S PSBTLE="PSBEXP",TEXT=PSBEXP D PROCESS
I PSBMFG]"" S PSBTLE="PSBMFG",TEXT=PSBMFG D PROCESS
I PSBFCB]"" S PSBTLE="PSBFCB",TEXT="Filled/Checked By: "_PSBFCB D PROCESS
;KCF HAZMAT *106
;I PSBHAZH]"" S PSBTLE="PSBHAZH",TEXT=PSBHAZH I $D(PSBCODE("HAZ")) X PSBCODE("HAZ") I $D(PSBCODE("ST")) X PSBCODE("ST")
;I PSBHAZD]"" S PSBTLE="PSBHAZD",TEXT=PSBHAZD I $D(PSBCODE("HAZ")) X PSBCODE("HAZ") I $D(PSBCODE("ST")) X PSBCODE("ST")
;I HAZTEXT]"" W !,"^FO20,90^A0N,22,20^CI13^FR^FD"_HAZTEXT_"^FS" ;*106
I HAZTEXT]"" S PSBTLE="HAZTEXT",TEXT=HAZTEXT I $D(PSBCODE("HAZ")) X PSBCODE("HAZ") I $D(PSBCODE("ST")) X PSBCODE("ST") ; *131 - Replacing patch 106 code in line above with 2018 solution proposed by KCF
Q
;
PROCESS ;Process control code and field data.
I $D(PSBCODE("STF")) X PSBCODE("STF")
I $D(PSBCODE("ST")) X PSBCODE("ST")
Q
;
BCSTRIP ; *106 - Adjust height of bar code if HAZ text exists
; *131 - No longer executing this code. Control Code "HAZ" was added.
; All M code executed through the Control Code.
;I HAZTEXT="" X PSBCODE("SB") Q
;I HAZTEXT]"" D
;. S:PSBSYM="" PSBBAR="NO-CODE"
;. S PSBTYPE=$S(PSBSYM="I25":"B2N",PSBSYM="128":"BCN",1:"B3N")
;. W !,"^BY2,3.0,80^FO20,115^"_PSBTYPE_",N,65,Y,N^FR^FD"_PSBBAR_"^FS"
Q
;
INPTR ;Input transform for DRUG field (#.31) in file 53.69.
N PSBIAD,PSBDEA,D,Y
K:$L(X)>40!($L(X)<1) X I $D(X) D
.S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.N DIC S DIC="^PSDRUG(",DIC(0)="EQNM",D="B^C^VAPN^VAC^NDC^XATC"
.S DIC("S")="I (($P($G(^PSDRUG(+Y,2)),U,3)[""I"")!($P($G(^(2)),U,3)[""U"")),(('$G(^PSDRUG(+Y,""I"")))!(DT'>$G(^(""I""))))"
.D:+X'>0 MIX^DIC1
.D:+X>0 ^DIC
.S:+Y>0 X=$$GET1^DIQ(50,+Y_",",.01)_"~"_+Y K:+Y<1 X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOBZ 6456 printed Dec 13, 2024@01:40:22 Page 2
PSBOBZ ;BIRMINGHAM/TTH-BAR CODE LABELS (MAIN) ;8/17/21 12:43
+1 ;;3.0;BAR CODE MED ADMIN;**2,70,81,106,131**;Mar 2004;Build 11
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference/IA
+5 ; ^%ZIS(2/3435
+6 ; File 50/221
+7 ;
+8 ;*70 - 1459: Adding clinic to BL and BZ chui labels.
+9 ;*106- add Hazardous to Handle & Dispose alert text
+10 ;
+11 ;*131 - Replaced patch 106 changes in PRINT section with suggestions made by KCF
EN ;
+1 NEW PSBI,PSBIENS,PSBQTY,PSBDOSE,PSBDRUG,PSBNAME,PSBNODE3,PSBWARD,PSBLOT,PSBBAR,PSBTLE,SL
+2 ;[*70-1459]
NEW PSBEXP,PSBFD,PSBMFG,PSBCB,PSBFB,PSBFCB,PSBCNT,PSBANS,PSBORD,PSBPRE,PSBX,PSBY,PSBSYM,TEXT,PSBCLIN
+3 ;*106
NEW PSBDD,PSBHZ,PSBHAZH,PSBHAZD,HAZTEXT
+4 ;
+5 NEW PSBXX,PSBYY,PSBCODE
+6 SET PSBXX=0
FOR
SET PSBXX=$ORDER(^%ZIS(2,IOST(0),55,PSBXX))
if 'PSBXX
QUIT
SET PSBYY=$GET(^(PSBXX,0))
IF PSBYY]""
SET PSBX=$PIECE(PSBYY,"^")
SET PSBY=^(1)
SET PSBCODE(PSBX)=PSBY
+7 ;
+8 ;The PSBRPT variable and PSBRPT(.3) array are set in the PSBO routine. It is the internal
+9 ;entry number from the BCMA REPORT REQUEST file (#53.69). This entry is created
+10 ;when the user submits the completed ScreenMan form from the Label Print option.
+11 ;
+12 ;
+13 SET PSBIENS=PSBRPT_","
+14 SET PSBBAR=$PIECE($PIECE($GET(PSBRPT(.3)),U,1),"~",2)
+15 SET PSBPRE=$$GET^XPAR("DIV","PSB DEFAULT BARCODE PREFIX")
+16 if PSBPRE]""
SET PSBBAR=PSBPRE_$SELECT(PSBPRE?1.N:"-",1:"")_PSBBAR
+17 SET PSBDRUG=$PIECE($PIECE($GET(PSBRPT(.3)),U,1),"~",1)
+18 SET PSBQTY=+$PIECE($GET(PSBRPT(.3)),U,5)
+19 if PSBQTY
SET PSBDRUG=PSBDRUG_" (Qty: "_PSBQTY_")"
+20 IF PSBQTY=0
SET PSBDRUG=PSBDRUG_" (Qty: )"
+21 SET PSBDOSE=$PIECE($GET(PSBRPT(.3)),U,9)
+22 IF PSBDOSE]""
SET PSBDOSE="Dose:"_PSBDOSE
+23 IF PSBDOSE=""
SET PSBDOSE="Dose:"
+24 SET PSBNAME=$$GET1^DIQ(53.69,PSBIENS,.12)
+25 ;add code for IHS, PSB*3*81
IF PSBNAME]""
SET PSBNAME=PSBNAME_" ("_$SELECT(DUZ("AG")="I":$$HRN^AUPNPAT($PIECE($GET(^PSB(53.69,+PSBIENS,.1)),U,2),$PIECE(^(0),U,4)),1:$EXTRACT($$GET1^DIQ(53.69,PSBIENS,.121),6,9))_")"
+26 IF PSBNAME=""
SET PSBNAME="Patient:"
+27 SET PSBWARD=$$GET1^DIQ(53.69,PSBIENS,.122)
+28 ;[*70-1459]
SET PSBCLIN=$$GET1^DIQ(53.69,PSBIENS,5)
+29 IF PSBWARD]""
SET PSBWARD="Ward: "_PSBWARD
+30 IF PSBWARD=""
SET PSBWARD="Ward: "
+31 ;[*70-1459]
IF PSBCLIN]""
SET PSBWARD="Clinic: "_PSBCLIN
+32 SET PSBLOT=$PIECE($GET(PSBRPT(.3)),U,2)
+33 IF PSBLOT]""
SET PSBLOT="Lot: "_PSBLOT
+34 IF PSBLOT=""
SET PSBLOT="Lot: "
+35 SET PSBFD=$PIECE($GET(PSBRPT(.3)),U,3)
+36 SET PSBEXP=$$FMTE^XLFDT(PSBFD,5)
+37 IF PSBEXP]""
SET PSBEXP="Exp: "_PSBEXP
+38 IF PSBEXP=""
SET PSBEXP="Exp: "
+39 SET PSBMFG=$PIECE($GET(PSBRPT(.3)),U,4)
+40 IF PSBMFG]""
SET PSBMFG="Mfg: "_PSBMFG
+41 IF PSBMFG=""
SET PSBMFG="Mfg: "
+42 SET PSBFB=$PIECE($GET(PSBRPT(.3)),U,6)
IF PSBFB=""
SET PSBFB="_____"
+43 SET PSBCB=$PIECE($GET(PSBRPT(.3)),U,7)
IF PSBCB=""
SET PSBCB="_____"
+44 SET PSBFCB=PSBFB_"/"_PSBCB
+45 ; get HAZ drug info *106
+46 SET PSBDD=$$GET1^DIQ(53.69,PSBIENS,.31,"I")
SET PSBHZ=$$HAZ^PSSUTIL($PIECE(PSBDD,"~",2))
+47 SET PSBHAZH=$SELECT($PIECE(PSBHZ,U):"<<HAZ Handle>>",1:"")
SET PSBHAZD=$SELECT($PIECE(PSBHZ,U,2):"<<HAZ Dispose>>",1:"")
+48 SET HAZTEXT=""
+49 IF $LENGTH(PSBHAZH)=0
Begin DoDot:1
+50 IF $LENGTH(PSBHAZD)>0
SET HAZTEXT=PSBHAZD
End DoDot:1
+51 IF $LENGTH(PSBHAZH)>0
Begin DoDot:1
+52 IF $LENGTH(PSBHAZD)=0
SET HAZTEXT=PSBHAZH
+53 IF $LENGTH(PSBHAZD)>0
SET HAZTEXT="<<HAZ Handle & HAZ Dispose>>"
End DoDot:1
+54 FOR PSBCNT=1:1:+$PIECE(PSBRPT(.3),U,8)
DO LABEL
+55 DO CLEAN^PSBVT
+56 QUIT
+57 ;
LABEL ;Get Barcode Label Type
+1 ;Barcode Type
+2 SET PSBSYM=$$GET^XPAR("DIV","PSB DEFAULT BARCODE FORMAT",,"E")
+3 ;
INIT ;Initialize barcode printer
+1 IF $DATA(PSBCODE("FI"))
XECUTE PSBCODE("FI")
+2 IF $DATA(PSBCODE("FI1"))
XECUTE PSBCODE("FI1")
+3 IF $DATA(PSBCODE("FI2"))
XECUTE PSBCODE("FI2")
+4 ;
+5 ;Additional format settings
+6 IF PSBSYM]""
IF $DATA(PSBCODE("SBF"))
XECUTE PSBCODE("SBF")
+7 IF PSBSYM=""
IF $DATA(PSBCODE("EBF"))
XECUTE PSBCODE("EBF")
+8 ;
+9 ;execute control codes to start label
DO START
+10 ;execute control codes to print label
DO PRINT
+11 ;
+12 ;Print Barcode Strip
+13 ;If barcode type is defined.
+14 ;I PSBSYM]"",$D(PSBCODE("SB")) S TEXT=PSBBAR D BCSTRIP ;106
+15 ;131 Restoring 2018 code
IF PSBSYM]""
IF $DATA(PSBCODE("SB"))
SET TEXT=PSBBAR
XECUTE PSBCODE("SB")
+16 ;If barcode type is not defined.
+17 ;I PSBSYM="",$D(PSBCODE("SB")) S TEXT="*NO BARCODE TYPE*" D BCSTRIP ;106
+18 ;131 Restoring 2018 code
IF PSBSYM=""
IF $DATA(PSBCODE("SB"))
SET TEXT="*NO BARCODE TYPE*"
XECUTE PSBCODE("SB")
+19 ;
END ; Close Label or End of Label
+1 IF $GET(PSBCODE("EL"))]""
XECUTE PSBCODE("EL")
+2 HANG 2
+3 QUIT
+4 ;
START ;Start Label Print Process
+1 IF $GET(PSBCODE("SL"))]""
XECUTE PSBCODE("SL")
+2 QUIT
+3 ;
PRINT ;Print barcode label
+1 ;
+2 IF PSBDRUG]""
SET PSBTLE="PSBDRUG"
SET TEXT="Drug: "_PSBDRUG
DO PROCESS
+3 IF PSBDOSE]""
SET PSBTLE="PSBDOSE"
SET TEXT=PSBDOSE
DO PROCESS
+4 IF PSBNAME]""
SET PSBTLE="PSBNAME"
SET TEXT=PSBNAME
DO PROCESS
+5 IF PSBWARD]""
SET PSBTLE="PSBWARD"
SET TEXT=PSBWARD
DO PROCESS
+6 IF PSBLOT]""
SET PSBTLE="PSBLOT"
SET TEXT=PSBLOT
DO PROCESS
+7 IF PSBEXP]""
SET PSBTLE="PSBEXP"
SET TEXT=PSBEXP
DO PROCESS
+8 IF PSBMFG]""
SET PSBTLE="PSBMFG"
SET TEXT=PSBMFG
DO PROCESS
+9 IF PSBFCB]""
SET PSBTLE="PSBFCB"
SET TEXT="Filled/Checked By: "_PSBFCB
DO PROCESS
+10 ;KCF HAZMAT *106
+11 ;I PSBHAZH]"" S PSBTLE="PSBHAZH",TEXT=PSBHAZH I $D(PSBCODE("HAZ")) X PSBCODE("HAZ") I $D(PSBCODE("ST")) X PSBCODE("ST")
+12 ;I PSBHAZD]"" S PSBTLE="PSBHAZD",TEXT=PSBHAZD I $D(PSBCODE("HAZ")) X PSBCODE("HAZ") I $D(PSBCODE("ST")) X PSBCODE("ST")
+13 ;I HAZTEXT]"" W !,"^FO20,90^A0N,22,20^CI13^FR^FD"_HAZTEXT_"^FS" ;*106
+14 ; *131 - Replacing patch 106 code in line above with 2018 solution proposed by KCF
IF HAZTEXT]""
SET PSBTLE="HAZTEXT"
SET TEXT=HAZTEXT
IF $DATA(PSBCODE("HAZ"))
XECUTE PSBCODE("HAZ")
IF $DATA(PSBCODE("ST"))
XECUTE PSBCODE("ST")
+15 QUIT
+16 ;
PROCESS ;Process control code and field data.
+1 IF $DATA(PSBCODE("STF"))
XECUTE PSBCODE("STF")
+2 IF $DATA(PSBCODE("ST"))
XECUTE PSBCODE("ST")
+3 QUIT
+4 ;
BCSTRIP ; *106 - Adjust height of bar code if HAZ text exists
+1 ; *131 - No longer executing this code. Control Code "HAZ" was added.
+2 ; All M code executed through the Control Code.
+3 ;I HAZTEXT="" X PSBCODE("SB") Q
+4 ;I HAZTEXT]"" D
+5 ;. S:PSBSYM="" PSBBAR="NO-CODE"
+6 ;. S PSBTYPE=$S(PSBSYM="I25":"B2N",PSBSYM="128":"BCN",1:"B3N")
+7 ;. W !,"^BY2,3.0,80^FO20,115^"_PSBTYPE_",N,65,Y,N^FR^FD"_PSBBAR_"^FS"
+8 QUIT
+9 ;
INPTR ;Input transform for DRUG field (#.31) in file 53.69.
+1 NEW PSBIAD,PSBDEA,D,Y
+2 if $LENGTH(X)>40!($LENGTH(X)<1)
KILL X
IF $DATA(X)
Begin DoDot:1
+3 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+4 NEW DIC
SET DIC="^PSDRUG("
SET DIC(0)="EQNM"
SET D="B^C^VAPN^VAC^NDC^XATC"
+5 SET DIC("S")="I (($P($G(^PSDRUG(+Y,2)),U,3)[""I"")!($P($G(^(2)),U,3)[""U"")),(('$G(^PSDRUG(+Y,""I"")))!(DT'>$G(^(""I""))))"
+6 if +X'>0
DO MIX^DIC1
+7 if +X>0
DO ^DIC
+8 if +Y>0
SET X=$$GET1^DIQ(50,+Y_",",.01)_"~"_+Y
if +Y<1
KILL X
End DoDot:1
+9 QUIT
