PSIVLABL ;BIR/PR-PRINT OUT LABELS ;03-Apr-2013 14:18;PLS
;;5.0; INPATIENT MEDICATIONS ;**58,82,104,127,178,184,1010,1015**;16 DEC 97;Build 62
;
; Reference to ^%ZIS(2 is supported by DBIA 3435.
; Reference to ^PS(52.6 is supported by DBIA 1231.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Modified - IHS/CIA/PLS - 12/05/03 - Line DEM+4
; IHS/MSC/PLS - 07/31/12 - Line INF+8
;Needs DFN,ON, and PSIVNOL NOTE: If PSIVCT is defined then we do
;not count labels in the STATs file or increment cummulative doses or
;the last fill field.
;PSIVCT will be defined if reprinting scheduled labels, the suspense
;list, or if printing individual labels and they do not count.
;
; Modified - IHS/MSC/PB - 4/25/12 to add expiration date to the iv label. Added line tag OFFSET,
;
DEM ;Get demographics and see if label is example only
N X0,PSJIO,I
S I=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=$G(^(I,0)) I X0]"" S PSJIO($P(X0,"^"))=^(1)
S PSJIO=$S('$D(PSJIO):0,1:1)
; IHS/CIA/PLS - 03/31/04 - Change SSN to HRN
;D ENIV^PSJAC,NOW^%DTC S PSIVNOW=$$ENDTC^PSGMI(%),VADM(2)=$E(VADM(2),6,9),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV") I $D(PSIVEXAM) G ENX
D ENIV^PSJAC,NOW^%DTC S PSIVNOW=$$ENDTC^PSGMI(%),VADM(2)=$G(VA("BID")),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV") I $D(PSIVEXAM) G ENX
;
G:PSIVNOL<1 Q D SETP S PSIVRM=$P(PSIVSITE,U,13),P16=$P($G(^PS(55,DFN,"IV",+ON,9)),U,3) S:PSIVRM<1 PSIVRM=30 I $D(PSIVCT),PSIVCT'=1 K PSIVCT
I PSJIO,$G(PSJIO("FI"))]"" X PSJIO("FI")
I $P(PSIVSITE,U,7) D
. S PSIVFLAG=1,(LINE,PSIV1)=0,PSIV2=PSIVNOL,PSIVNOL=0 D RE
. S PSIVRP="",PSIVRT=""
. I $D(^PS(55,DFN,"IV",+ON,.2)) S PSIVRP=$P(^PS(55,DFN,"IV",+ON,.2),U,3) D
.. I PSIV1'>0!'$P(PSIVSITE,U,3)!($P(PSIVSITE,U,3)=1&(P(4)'="P"))!($P(PSIVSITE,U,3)=2&("AH"'[P(4))) Q ;DO NOT PRINT ROUTE IF "DOSE DUE AT" IS SET TO NOT PRINT.
.. S PSIVRT=$P(^PS(51.2,PSIVRP,0),U,1)
.. S X="ROUTE: "_PSIVRT D:X]"" PMR
. S X="Solution: _______________" D P S X="Additive: _______________" D P
. S PSIVNOL=PSIV2
. I 'PSJIO F LINE=LINE+1:1:(PSIVSITE+$P(PSIVSITE,U,16)) W !
. I PSJIO,$G(PSJIO("EL"))]"" X PSJIO("EL")
I '$D(PSIVCT) D NOW^%DTC S Y=%,$P(^PS(55,DFN,"IV",+ON,9),U,1,2)=Y_"^"_PSIVNOL,$P(^(9),U,3)=$P(^(9),U,3)+PSIVNOL
K PSIVFLAG,PSIVSH G START
SETP S Y=^PS(55,DFN,"IV",+ON,0) F X=1:1:23 S P(X)=$P(Y,U,X)
Q
ENX ;Print example label
D SETP S PSIVFLAG=1,PSIVRM=$P(PSIVSITE,U,13) S:PSIVRM<1 PSIVRM=30
START F PSIV1=1:1:PSIVNOL D
. S LINE=0 D RE
. Q:$D(PSIVFLAG)
. I 'PSJIO F LINE=LINE+1:1:(PSIVSITE+$P(PSIVSITE,U,16)) W !
. I PSJIO,$G(PSJIO("EL"))]"" X PSJIO("EL")
I PSJIO,$G(PSJIO("FE"))]"" X PSJIO("FE")
D:'$D(PSIVCT) ^PSIVSTAT
Q K PSIV,PSIVDOSE,PSIVWD,P16,LINE,MESS,PSIVCT,PSIV2,PSIVFLAG,PSIVRM,PSIV1,PDOSE,PDATE,XX1,XX2,BAG,CX,PSIMESS,TEXT1 Q
RE ;
K DO
I PSIV1,P(4)="A"!(P(5)=0) S P(16)=PSIV1 I $G(PSIVT)]"" D
. S:P(15)>2880!('P(15)) P(15)=2880 S P(16)=P16+PSIV1#(1440/P(15)+.5\1) S:'P(16) P(16)=PSIV1
I PSIV1 S PSJBCID=$$BCMA^PSIVBCID(DFN,ON,$D(PSIVCT),$G(PSIV1),$G(PSIV2),$G(PSIVNOL))
;* Only if prt from ward or man list then store BCMA ID to set xref for
;* reprint later
I PSIV1,$G(PSIVWMFL) S PSIVID($P(PSJBCID,"V",2))=""
I PSJIO,$G(PSJIO("SL"))]"" X PSJIO("SL")
I PSIV1 D BARCODE
;IHS/MSC/PB - 04/25/12 - next line computes the IV label expiration date
I $P($G(^PS(59.5,PSIVSN,9999999)),U)=1 D ;,$P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'="" D
.N EXDT,XX1
.I $P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'>0 S TEXT1="________" Q
.S XX1=$P(^PS(55,DFN,"IV",+ON,9999999),U),EXDT=$$FMADD^XLFDT($$DT^XLFDT(),XX1)
.S TEXT1=$$FMTE^XLFDT(EXDT,"5Z")
S X="["_$P(^PS(55,DFN,"IV",+ON,0),U)_"]"_" "_VADM(2)_" "_PSIVWD_" "_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) D P
S X=VADM(1) S:$P(PSIVSITE,U,9) X=X_" "_$S(VAIN(5)]"":VAIN(5),1:"NF") D P S X=" " D P
I $D(PSIVFLAG) F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IV",+ON,"AD",PSIV)) Q:'PSIV S Y=^(PSIV,0),X=$S($D(^PS(52.6,+Y,0)):$P(^(0),"^"),1:"*********")_" "_$P(Y,U,2)_" " S:$P(Y,U,3)]"" X=X_" ("_$P(Y,U,3)_")" D
. D P
. ;I PSIV1 S YY=Y D UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY) S Y=YY
. D MESS
G:$D(PSIVFLAG) SOL
; IV BOTTLE functionality, 3rd piece of PS(55,DFN,"IV",+ON,"AD",PSIV,0) dictates labels per LABEL RUN on which the additive will print
F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IV",+ON,"AD",PSIV)) Q:'PSIV S Y=^(PSIV,0),X=$S($D(^PS(52.6,+Y,0)):$P(^(0),U),1:"********")_" "_$P(Y,U,2) I ","_$P(Y,U,3)_","[(","_P(16)_",")!('$P(Y,U,3)) D
. D P
. I PSIV1 S YY=Y D UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY) S Y=YY
. D MESS
;
SOL F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IV",+ON,"SOL",PSIV)) Q:'PSIV S PSIV=PSIV_"^"_+^(PSIV,0),YY=^(0) D
. D SOL1,P I PSIV1 D UP3^PSIVBCID(DFN,PSJBLN,PSIV,YY)
. S X=$P(^PS(52.7,$P(PSIV,U,2),0),U,4) I X]"" S X=" "_X D P
I P(23)'=""!(P(4)="S") S X="In Syringe: "_$E($P(^PS(55,DFN,"IV",+ON,2),U,4),1,25) D:P(4)="S"!(P(23)="S") P S X="*CAUTION* - CHEMOTHERAPY" D:P(23)'="" P
S X=" " D P I PSIV1'>0!'$P(PSIVSITE,U,3)!($P(PSIVSITE,U,3)=1&(P(4)'="P"))!($P(PSIVSITE,U,3)=2&("AH"'[P(4))) G MEDRT
S:'$D(PSIVDOSE) PSIVDOSE="" S X=$P(PSIVDOSE," ",PSIV1) D:$E(X)="." CONVER S X="Dose due at: "_$S(X="":"________",1:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" "_$E(X#1_"000",2,5)) D P
;
MEDRT ;Find Medication Route
S PSIVRP="",PSIVRT=""
I $D(^PS(55,DFN,"IV",+ON,.2)) S PSIVRP=$P(^PS(55,DFN,"IV",+ON,.2),U,3) D
.S PSIVRT=$P(^PS(51.2,PSIVRP,0),U,1)
.S X="ROUTE: "_PSIVRT D:X]"" PMR
;
INF S X=$P(P(8),"@") D:X]"" P
I $D(^PS(55,DFN,"IV",+ON,3)) S X=$P(^(3),"^") D:X]"" P
S X=P(9) D:X]"" P
S X=P(11) D:X]"" P
;PSJ*5*184 - Display all messages if more than one additive has a message.
I $D(MESS) S PSIMESS="" F S PSIMESS=$O(MESS(PSIMESS)) Q:PSIMESS="" S X=PSIMESS D P
I $D(^PS(59.5,PSIVSN,4)) S Y=^(4) F PSIV=1:1 S X=$P(Y,U,PSIV) Q:X="" D P
;MSC/IHS/PB - 3/1/13 modified to incorporate VA changes for BCMA project
;S X=PSIV1_"["_$S(PSIV1:PSIVNOL,1:PSIV2)_"]"_" "_$S('PSIV1:PSIVNOW,1:"") D P
;IHS/MSC/PB - 04/25/12 - next line prints the expiration date and text as the last line on the IV label IF there is an offset date for the IV
;I $G(TEXT1)'="" D OFFSET("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P
;IHS KCF VA0IT 2-2013 prints the expiration date and text as the last line on the IV label IF there is an offset date for the right label count.
S X=PSIV1_"["_$S(PSIV1:PSIVNOL,1:PSIV2)_"]"_" "_$S('PSIV1:PSIVNOW,1:"") I $G(TEXT1)'="" D OFFSET(X,"Do Not Use After: "_TEXT1) I $G(PRTFLG)=0 S X=$G(PRTLINE)
D P
Q
;
P F LINE=LINE+1:1 D Q:$L(X)<1
. I LINE>PSIVSITE D
.. S LINE=1
.. I 'PSJIO D Q
... F ZZ=1:1 Q:ZZ>$P(PSIVSITE,"^",16) W !
.. F I="EL","SL" I $G(PSJIO(I))]"" X PSJIO(I)
. K ZZ
. F I="ST","STF" I $G(PSJIO(I))]"" X PSJIO(I)
. W $E(X,1,PSIVRM)
. F I="ETF","ET" I $G(PSJIO(I))]"" X PSJIO(I)
. I 'PSJIO W !
. S X=$E(X,PSIVRM+1,999)
Q
PMR ; Print Med Route on label
;
F LINE=LINE+1:1 D Q:$L(X)<1
. I LINE>PSIVSITE D
.. S LINE=1
.. I 'PSJIO D Q
... F ZZ=1:1 Q:ZZ>$P(PSIVSITE,"^",16) W !
.. F I="EL","SL" I $G(PSJIO(I))]"" X PSJIO(I)
. K ZZ
. ;
. F I="ST","STF","SM","SMF" I $G(PSJIO(I))]"" X PSJIO(I)
. W $E(X,1,PSIVRM)
. F I="ETF","ET","EMF","EM" I $G(PSJIO(I))]"" X PSJIO(I)
. I 'PSJIO W !
. S X=$E(X,PSIVRM+1,999)
Q
;
SOL1 S X=$S($D(^PS(52.7,$P(PSIV,U,2),0)):$P(^(0),"^")_" "_$P(^PS(55,DFN,"IV",+ON,"SOL",+PSIV,0),U,2),1:"**********") Q
MESS ;PSJ*5*184 -make MESS a local array so all messages display for all additives.
I $P(^PS(52.6,+Y,0),U,9)]"" S MESS($P(^PS(52.6,+Y,0),U,9))=""
Q
CONVER ;Expand dose to date.dose and set in X
I P(15)>1440 S X=$$CONVER1^PSIVORE2($P(PSIVDOSE," "),P(15),(PSIV1-1)) Q
S PDOSE=X S:PSIV1=2 PDATE=$E($P(PSIVDOSE," "),1,7)
I $P(PSIVDOSE," ",PSIV1-1)#1'<PDOSE!(P(15)>1440) S:$D(X1) XX1=X1 S:$D(X2) XX2=X2 S X1=PDATE,X2=1 D C^%DTC S PDATE=X,X=X_PDOSE S:$D(XX1) X1=XX1 S:$D(XX2) X2=XX2 Q
S X=PDATE_PDOSE
Q
BARCODE D PSET^%ZISP
I 'PSJIO D
. I IOBARON]"" W @IOBARON
. W PSJBCID
. I IOBAROFF]"" W @IOBAROFF
. W !
I PSJIO D
. F I="SB","SBF" I $G(PSJIO(I))]"" X PSJIO(I)
. W PSJBCID
. F I="EBF","EB" I $G(PSJIO(I))]"" X PSJIO(I)
Q
;IHS/MSC/PB - 04/25/12 - next line tag added to compute length of lines with the new iv label expiration date data added to the first two lines. Code will check to be sure
;that adding the new words "Do Not Use After:" to the first line of the label will not cause the line to be too long to print on the first line
;if the new words plus the original text don't exceed the label width as specified in the IV Room file, data will print on the first line. if the text is too long
;the flag PRTFLG is set to one and the new data and the expiration date will print as the last line of the label. This same process takes place for the second line
;on the label except the check is to be sure the original text and the expiration date won't exceed the max number of characters.
;
OFFSET(TEXT,TEXT1) ;IHS/MSC/PB - 4/25/12 - computes length of text on a line, TEXT = the label data from the existing line, TEXT1 = the new text "Do Not Use After:" or the date depending on the line being printed
;PRTFLG used to determine where to print the new data. PRTFLG = 1, print on a separate line PRTFLG=0 print on the same line as the original text printed
S LABWID=$P(^PS(59.5,PSIVSN,1),"^",13),PRTFLG=0
S SPACES=LABWID-($L(TEXT)+$L(TEXT1))
S NEWTEXT="",I=1 F I=1:1:SPACES S NEWTEXT=NEWTEXT_" "
S PRTLINE=TEXT_NEWTEXT_TEXT1
S:$L(PRTLINE)>LABWID PRTFLG=1 ; too many characters to print on one line.
S:SPACES'>4 PRTFLG=1 ; Not enough spaces between the original text and the new text to print on the same line
;K LABWID,TEXTLEN,SPACES,LTEXT,NEWTEXT
Q
PSIVLABL ;BIR/PR-PRINT OUT LABELS ;03-Apr-2013 14:18;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**58,82,104,127,178,184,1010,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^%ZIS(2 is supported by DBIA 3435.
+4 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+5 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+6 ; Reference to ^PS(55 is supported by DBIA 2191.
+7 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+8 ; Modified - IHS/CIA/PLS - 12/05/03 - Line DEM+4
+9 ; IHS/MSC/PLS - 07/31/12 - Line INF+8
+10 ;Needs DFN,ON, and PSIVNOL NOTE: If PSIVCT is defined then we do
+11 ;not count labels in the STATs file or increment cummulative doses or
+12 ;the last fill field.
+13 ;PSIVCT will be defined if reprinting scheduled labels, the suspense
+14 ;list, or if printing individual labels and they do not count.
+15 ;
+16 ; Modified - IHS/MSC/PB - 4/25/12 to add expiration date to the iv label. Added line tag OFFSET,
+17 ;
DEM ;Get demographics and see if label is example only
+1 NEW X0,PSJIO,I
+2 SET I=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
IF 'I
QUIT
SET X0=$GET(^(I,0))
IF X0]""
SET PSJIO($PIECE(X0,"^"))=^(1)
+3 SET PSJIO=$SELECT('$DATA(PSJIO):0,1:1)
+4 ; IHS/CIA/PLS - 03/31/04 - Change SSN to HRN
+5 ;D ENIV^PSJAC,NOW^%DTC S PSIVNOW=$$PSGMI_source.html#ENDTC">ENDTC^PSGMI(%),VADM(2)=$E(VADM(2),6,9),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV") I $D(PSIVEXAM) G ENX
+6 DO ENIV^PSJAC
DO NOW^%DTC
SET PSIVNOW=$$ENDTC^PSGMI(%)
SET VADM(2)=$GET(VA("BID"))
SET PSIVWD=$SELECT(+VAIN(4):$PIECE(VAIN(4),U,2),1:"Opt. IV")
IF $DATA(PSIVEXAM)
GOTO ENX
+7 ;
+8 IF PSIVNOL<1
GOTO Q
DO SETP
SET PSIVRM=$PIECE(PSIVSITE,U,13)
SET P16=$PIECE($GET(^PS(55,DFN,"IV",+ON,9)),U,3)
IF PSIVRM<1
SET PSIVRM=30
IF $DATA(PSIVCT)
IF PSIVCT'=1
KILL PSIVCT
+9 IF PSJIO
IF $GET(PSJIO("FI"))]""
XECUTE PSJIO("FI")
+10 IF $PIECE(PSIVSITE,U,7)
Begin DoDot:1
+11 SET PSIVFLAG=1
SET (LINE,PSIV1)=0
SET PSIV2=PSIVNOL
SET PSIVNOL=0
DO RE
+12 SET PSIVRP=""
SET PSIVRT=""
+13 IF $DATA(^PS(55,DFN,"IV",+ON,.2))
SET PSIVRP=$PIECE(^PS(55,DFN,"IV",+ON,.2),U,3)
Begin DoDot:2
+14 ;DO NOT PRINT ROUTE IF "DOSE DUE AT" IS SET TO NOT PRINT.
IF PSIV1'>0!'$PIECE(PSIVSITE,U,3)!($PIECE(PSIVSITE,U,3)=1&(P(4)'="P"))!($PIECE(PSIVSITE,U,3)=2&("AH"'[P(4)))
QUIT
+15 SET PSIVRT=$PIECE(^PS(51.2,PSIVRP,0),U,1)
+16 SET X="ROUTE: "_PSIVRT
IF X]""
DO PMR
End DoDot:2
+17 SET X="Solution: _______________"
DO P
SET X="Additive: _______________"
DO P
+18 SET PSIVNOL=PSIV2
+19 IF 'PSJIO
FOR LINE=LINE+1:1:(PSIVSITE+$PIECE(PSIVSITE,U,16))
WRITE !
+20 IF PSJIO
IF $GET(PSJIO("EL"))]""
XECUTE PSJIO("EL")
End DoDot:1
+21 IF '$DATA(PSIVCT)
DO NOW^%DTC
SET Y=%
SET $PIECE(^PS(55,DFN,"IV",+ON,9),U,1,2)=Y_"^"_PSIVNOL
SET $PIECE(^(9),U,3)=$PIECE(^(9),U,3)+PSIVNOL
+22 KILL PSIVFLAG,PSIVSH
GOTO START
SETP SET Y=^PS(55,DFN,"IV",+ON,0)
FOR X=1:1:23
SET P(X)=$PIECE(Y,U,X)
+1 QUIT
ENX ;Print example label
+1 DO SETP
SET PSIVFLAG=1
SET PSIVRM=$PIECE(PSIVSITE,U,13)
IF PSIVRM<1
SET PSIVRM=30
START FOR PSIV1=1:1:PSIVNOL
Begin DoDot:1
+1 SET LINE=0
DO RE
+2 IF $DATA(PSIVFLAG)
QUIT
+3 IF 'PSJIO
FOR LINE=LINE+1:1:(PSIVSITE+$PIECE(PSIVSITE,U,16))
WRITE !
+4 IF PSJIO
IF $GET(PSJIO("EL"))]""
XECUTE PSJIO("EL")
End DoDot:1
+5 IF PSJIO
IF $GET(PSJIO("FE"))]""
XECUTE PSJIO("FE")
+6 IF '$DATA(PSIVCT)
DO ^PSIVSTAT
Q KILL PSIV,PSIVDOSE,PSIVWD,P16,LINE,MESS,PSIVCT,PSIV2,PSIVFLAG,PSIVRM,PSIV1,PDOSE,PDATE,XX1,XX2,BAG,CX,PSIMESS,TEXT1
QUIT
RE ;
+1 KILL DO
+2 IF PSIV1
IF P(4)="A"!(P(5)=0)
SET P(16)=PSIV1
IF $GET(PSIVT)]""
Begin DoDot:1
+3 IF P(15)>2880!('P(15))
SET P(15)=2880
SET P(16)=P16+PSIV1#(1440/P(15)+.5\1)
IF 'P(16)
SET P(16)=PSIV1
End DoDot:1
+4 IF PSIV1
SET PSJBCID=$$BCMA^PSIVBCID(DFN,ON,$DATA(PSIVCT),$GET(PSIV1),$GET(PSIV2),$GET(PSIVNOL))
+5 ;* Only if prt from ward or man list then store BCMA ID to set xref for
+6 ;* reprint later
+7 IF PSIV1
IF $GET(PSIVWMFL)
SET PSIVID($PIECE(PSJBCID,"V",2))=""
+8 IF PSJIO
IF $GET(PSJIO("SL"))]""
XECUTE PSJIO("SL")
+9 IF PSIV1
DO BARCODE
+10 ;IHS/MSC/PB - 04/25/12 - next line computes the IV label expiration date
+11 ;,$P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'="" D
IF $PIECE($GET(^PS(59.5,PSIVSN,9999999)),U)=1
Begin DoDot:1
+12 NEW EXDT,XX1
+13 IF $PIECE($GET(^PS(55,DFN,"IV",+ON,9999999)),U)'>0
SET TEXT1="________"
QUIT
+14 SET XX1=$PIECE(^PS(55,DFN,"IV",+ON,9999999),U)
SET EXDT=$$FMADD^XLFDT($$DT^XLFDT(),XX1)
+15 SET TEXT1=$$FMTE^XLFDT(EXDT,"5Z")
End DoDot:1
+16 SET X="["_$PIECE(^PS(55,DFN,"IV",+ON,0),U)_"]"_" "_VADM(2)_" "_PSIVWD_" "_$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)
DO P
+17 SET X=VADM(1)
IF $PIECE(PSIVSITE,U,9)
SET X=X_" "_$SELECT(VAIN(5)]"":VAIN(5),1:"NF")
DO P
SET X=" "
DO P
+18 IF $DATA(PSIVFLAG)
FOR PSIV=0:0
SET PSIV=$ORDER(^PS(55,DFN,"IV",+ON,"AD",PSIV))
IF 'PSIV
QUIT
SET Y=^(PSIV,0)
SET X=$SELECT($DATA(^PS(52.6,+Y,0)):$PIECE(^(0),"^"),1:"*********")_" "_$PIECE(Y,U,2)_" "
IF $PIECE(Y,U,3)]""
SET X=X_" ("_$PIECE(Y,U,3)_")"
Begin DoDot:1
+19 DO P
+20 ;I PSIV1 S YY=Y D UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY) S Y=YY
+21 DO MESS
End DoDot:1
+22 IF $DATA(PSIVFLAG)
GOTO SOL
+23 ; IV BOTTLE functionality, 3rd piece of PS(55,DFN,"IV",+ON,"AD",PSIV,0) dictates labels per LABEL RUN on which the additive will print
+24 FOR PSIV=0:0
SET PSIV=$ORDER(^PS(55,DFN,"IV",+ON,"AD",PSIV))
IF 'PSIV
QUIT
SET Y=^(PSIV,0)
SET X=$SELECT($DATA(^PS(52.6,+Y,0)):$PIECE(^(0),U),1:"********")_" "_$PIECE(Y,U,2)
IF ","_$PIECE(Y,U,3)_","[(","_P(16)_",")!('$PIECE(Y,U,3))
Begin DoDot:1
+25 DO P
+26 IF PSIV1
SET YY=Y
DO UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY)
SET Y=YY
+27 DO MESS
End DoDot:1
+28 ;
SOL FOR PSIV=0:0
SET PSIV=$ORDER(^PS(55,DFN,"IV",+ON,"SOL",PSIV))
IF 'PSIV
QUIT
SET PSIV=PSIV_"^"_+^(PSIV,0)
SET YY=^(0)
Begin DoDot:1
+1 DO SOL1
DO P
IF PSIV1
DO UP3^PSIVBCID(DFN,PSJBLN,PSIV,YY)
+2 SET X=$PIECE(^PS(52.7,$PIECE(PSIV,U,2),0),U,4)
IF X]""
SET X=" "_X
DO P
End DoDot:1
+3 IF P(23)'=""!(P(4)="S")
SET X="In Syringe: "_$EXTRACT($PIECE(^PS(55,DFN,"IV",+ON,2),U,4),1,25)
IF P(4)="S"!(P(23)="S")
DO P
SET X="*CAUTION* - CHEMOTHERAPY"
IF P(23)'=""
DO P
+4 SET X=" "
DO P
IF PSIV1'>0!'$PIECE(PSIVSITE,U,3)!($PIECE(PSIVSITE,U,3)=1&(P(4)'="P"))!($PIECE(PSIVSITE,U,3)=2&("AH"'[P(4)))
GOTO MEDRT
+5 IF '$DATA(PSIVDOSE)
SET PSIVDOSE=""
SET X=$PIECE(PSIVDOSE," ",PSIV1)
IF $EXTRACT(X)="."
DO CONVER
SET X="Dose due at: "_$SELECT(X="":"________",1:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" "_$EXTRACT(X#1_"000",2,5))
DO P
+6 ;
MEDRT ;Find Medication Route
+1 SET PSIVRP=""
SET PSIVRT=""
+2 IF $DATA(^PS(55,DFN,"IV",+ON,.2))
SET PSIVRP=$PIECE(^PS(55,DFN,"IV",+ON,.2),U,3)
Begin DoDot:1
+3 SET PSIVRT=$PIECE(^PS(51.2,PSIVRP,0),U,1)
+4 SET X="ROUTE: "_PSIVRT
IF X]""
DO PMR
End DoDot:1
+5 ;
INF SET X=$PIECE(P(8),"@")
IF X]""
DO P
+1 IF $DATA(^PS(55,DFN,"IV",+ON,3))
SET X=$PIECE(^(3),"^")
IF X]""
DO P
+2 SET X=P(9)
IF X]""
DO P
+3 SET X=P(11)
IF X]""
DO P
+4 ;PSJ*5*184 - Display all messages if more than one additive has a message.
+5 IF $DATA(MESS)
SET PSIMESS=""
FOR
SET PSIMESS=$ORDER(MESS(PSIMESS))
IF PSIMESS=""
QUIT
SET X=PSIMESS
DO P
+6 IF $DATA(^PS(59.5,PSIVSN,4))
SET Y=^(4)
FOR PSIV=1:1
SET X=$PIECE(Y,U,PSIV)
IF X=""
QUIT
DO P
+7 ;MSC/IHS/PB - 3/1/13 modified to incorporate VA changes for BCMA project
+8 ;S X=PSIV1_"["_$S(PSIV1:PSIVNOL,1:PSIV2)_"]"_" "_$S('PSIV1:PSIVNOW,1:"") D P
+9 ;IHS/MSC/PB - 04/25/12 - next line prints the expiration date and text as the last line on the IV label IF there is an offset date for the IV
+10 ;I $G(TEXT1)'="" D OFFSET("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P
+11 ;IHS KCF VA0IT 2-2013 prints the expiration date and text as the last line on the IV label IF there is an offset date for the right label count.
+12 SET X=PSIV1_"["_$SELECT(PSIV1:PSIVNOL,1:PSIV2)_"]"_" "_$SELECT('PSIV1:PSIVNOW,1:"")
IF $GET(TEXT1)'=""
DO OFFSET(X,"Do Not Use After: "_TEXT1)
IF $GET(PRTFLG)=0
SET X=$GET(PRTLINE)
+13 DO P
+14 QUIT
+15 ;
P FOR LINE=LINE+1:1
Begin DoDot:1
+1 IF LINE>PSIVSITE
Begin DoDot:2
+2 SET LINE=1
+3 IF 'PSJIO
Begin DoDot:3
+4 FOR ZZ=1:1
IF ZZ>$PIECE(PSIVSITE,"^",16)
QUIT
WRITE !
End DoDot:3
QUIT
+5 FOR I="EL","SL"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
End DoDot:2
+6 KILL ZZ
+7 FOR I="ST","STF"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+8 WRITE $EXTRACT(X,1,PSIVRM)
+9 FOR I="ETF","ET"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+10 IF 'PSJIO
WRITE !
+11 SET X=$EXTRACT(X,PSIVRM+1,999)
End DoDot:1
IF $LENGTH(X)<1
QUIT
+12 QUIT
PMR ; Print Med Route on label
+1 ;
+2 FOR LINE=LINE+1:1
Begin DoDot:1
+3 IF LINE>PSIVSITE
Begin DoDot:2
+4 SET LINE=1
+5 IF 'PSJIO
Begin DoDot:3
+6 FOR ZZ=1:1
IF ZZ>$PIECE(PSIVSITE,"^",16)
QUIT
WRITE !
End DoDot:3
QUIT
+7 FOR I="EL","SL"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
End DoDot:2
+8 KILL ZZ
+9 ;
+10 FOR I="ST","STF","SM","SMF"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+11 WRITE $EXTRACT(X,1,PSIVRM)
+12 FOR I="ETF","ET","EMF","EM"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+13 IF 'PSJIO
WRITE !
+14 SET X=$EXTRACT(X,PSIVRM+1,999)
End DoDot:1
IF $LENGTH(X)<1
QUIT
+15 QUIT
+16 ;
SOL1 SET X=$SELECT($DATA(^PS(52.7,$PIECE(PSIV,U,2),0)):$PIECE(^(0),"^")_" "_$PIECE(^PS(55,DFN,"IV",+ON,"SOL",+PSIV,0),U,2),1:"**********")
QUIT
MESS ;PSJ*5*184 -make MESS a local array so all messages display for all additives.
+1 IF $PIECE(^PS(52.6,+Y,0),U,9)]""
SET MESS($PIECE(^PS(52.6,+Y,0),U,9))=""
+2 QUIT
CONVER ;Expand dose to date.dose and set in X
+1 IF P(15)>1440
SET X=$$CONVER1^PSIVORE2($PIECE(PSIVDOSE," "),P(15),(PSIV1-1))
QUIT
+2 SET PDOSE=X
IF PSIV1=2
SET PDATE=$EXTRACT($PIECE(PSIVDOSE," "),1,7)
+3 IF $PIECE(PSIVDOSE," ",PSIV1-1)#1'<PDOSE!(P(15)>1440)
IF $DATA(X1)
SET XX1=X1
IF $DATA(X2)
SET XX2=X2
SET X1=PDATE
SET X2=1
DO C^%DTC
SET PDATE=X
SET X=X_PDOSE
IF $DATA(XX1)
SET X1=XX1
IF $DATA(XX2)
SET X2=XX2
QUIT
+4 SET X=PDATE_PDOSE
+5 QUIT
BARCODE DO PSET^%ZISP
+1 IF 'PSJIO
Begin DoDot:1
+2 IF IOBARON]""
WRITE @IOBARON
+3 WRITE PSJBCID
+4 IF IOBAROFF]""
WRITE @IOBAROFF
+5 WRITE !
End DoDot:1
+6 IF PSJIO
Begin DoDot:1
+7 FOR I="SB","SBF"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+8 WRITE PSJBCID
+9 FOR I="EBF","EB"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
End DoDot:1
+10 QUIT
+11 ;IHS/MSC/PB - 04/25/12 - next line tag added to compute length of lines with the new iv label expiration date data added to the first two lines. Code will check to be sure
+12 ;that adding the new words "Do Not Use After:" to the first line of the label will not cause the line to be too long to print on the first line
+13 ;if the new words plus the original text don't exceed the label width as specified in the IV Room file, data will print on the first line. if the text is too long
+14 ;the flag PRTFLG is set to one and the new data and the expiration date will print as the last line of the label. This same process takes place for the second line
+15 ;on the label except the check is to be sure the original text and the expiration date won't exceed the max number of characters.
+16 ;
OFFSET(TEXT,TEXT1) ;IHS/MSC/PB - 4/25/12 - computes length of text on a line, TEXT = the label data from the existing line, TEXT1 = the new text "Do Not Use After:" or the date depending on the line being printed
+1 ;PRTFLG used to determine where to print the new data. PRTFLG = 1, print on a separate line PRTFLG=0 print on the same line as the original text printed
+2 SET LABWID=$PIECE(^PS(59.5,PSIVSN,1),"^",13)
SET PRTFLG=0
+3 SET SPACES=LABWID-($LENGTH(TEXT)+$LENGTH(TEXT1))
+4 SET NEWTEXT=""
SET I=1
FOR I=1:1:SPACES
SET NEWTEXT=NEWTEXT_" "
+5 SET PRTLINE=TEXT_NEWTEXT_TEXT1
+6 ; too many characters to print on one line.
IF $LENGTH(PRTLINE)>LABWID
SET PRTFLG=1
+7 ; Not enough spaces between the original text and the new text to print on the same line
IF SPACES'>4
SET PRTFLG=1
+8 ;K LABWID,TEXTLEN,SPACES,LTEXT,NEWTEXT
+9 QUIT
