PSIVHYPL ;BIR/PR-PRINT OUT LABELS ;05-May-2014 19:00;DU
;;5.0; INPATIENT MEDICATIONS ;**58,96,128,178,184,1010,1015,1018**;16 DEC 97;Build 21
;
; 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(50.4 is supported by DBIA 2175.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Modified - IHS/CIA/PLS - 12/05/03 Line SSWARD+4
;NEEDS DFN, ON AND PSIVNOL (Total number of labels to print) and
;PSIVCT - $D(PSIVCT) NO COUNT LABEL
;
; Modified - IHS/MSC/PB - 4/25/12 to add expiration date to the iv label. Added line tag OFFSET,
; lines BARCODE+1,2,&3
; - IHS/MSC/PB - 2/11/13 modified line BARCODE + 3 to use a $G to prevent errors if the PRTFLG variable is not set
; - IHS/MSC/PB - 2/13/13 modified line RE+7 to set the TEXT1 variable to "_________" if the offset is '>0
; - IHS/MSC/PB - 3/1/13 modified to incorporate changes made by VA for BCMA project
; IHS/MSC/PLS - 05/05/14 - Removed modifications at BARCODE+1
SSWARD ;Get patient SS# and ward location
N X0,PSJIO,I
S I=0 F S I=$O(^%ZIS(2,IOST(0),55,I)) Q:'I S X0=^(I,0),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 S VADM(2)=$E(VADM(2),6,9),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV")
D ENIV^PSJAC S VADM(2)=$G(VA("BID")),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV")
G:PSIVNOL<1 Q D SETP,^PSIVHYP 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 ;QUIT IF "DOSE DUE AT" LINE 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 PRNTL S X="Additive: _______________" D PRNTL
. 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
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 HYPL,LINE,MESS,P16,PDATE,PDOSE,PSIV,PSIVA,PSIV1,PSIV2,PSIVCT,PSIVDOSE,PSIVFLAG,PSIVRM,PSIVWD,TVOL,HYPLPRT,PSIMESS,TEXT1,IHSEXDT Q
RE I PSIV1 S:P(15)>2880!('P(15)) P(15)=2880 S P(16)=P16+PSIV1#(1440/P(15)+.5\1) S:'P(16) P(16)=1440/P(15)+.5\1
K DO
I PSJIO,$G(PSJIO("SL"))]"" X PSJIO("SL")
I PSIV1 S PSJBCID=$$BCMA^PSIVBCID(DFN,ON,$D(PSIVCT),$G(PSIV1),$G(PSIV2),$G(PSIVNOL)) D BARCODE
;IHS/MSC/PB - 4/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,1)'="" D
.;IHS/MSC/PB - 2/13/13 modified the line below to set TEXT1 = "___________" if the offset parameter is 0 or null
.;Q:$P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'>0
.N EXDT,XX1
.I $P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'>0 S (IHSEXDT,TEXT1)="________" Q
.S XX1=$P(^PS(55,DFN,"IV",+ON,9999999),U),EXDT=$$FMADD^XLFDT($$DT^XLFDT(),XX1)
.S (IHSEXDT,TEXT1)=$$FMTE^XLFDT(EXDT,"5Z")
.;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
;.S IHSEXDT=TEXT1 ;D OFFSET^PSIVLABL(X,TEXT1)
;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
;APSP/PB modified the following line to print the expiration date on the second line.
;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="["_$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($G(^PS(59.5,PSIVSN,9999999)),"^")=1&($D(TEXT1)) OFFSET^PSIVLABL(X,TEXT1)
;I $G(PRTFLG)=0 S X=$G(PRTLINE)
;D PRNTL
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 PRNTL
S X=VADM(1) S:$P(PSIVSITE,U,9) X=X_" "_$S(VAIN(5)]"":VAIN(5),1:"NF") D PRNTL S X=" " D PRNTL
D:$P(PSIVSITE,U,12) TVOL
S X="",$P(X,"=",PSIVRM-1)="" D PRNTL
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),U),1:"*********")_" "_$P(Y,U,2)_" " S:$P(Y,U,3)]"" X=X_" ("_$P(Y,U,3)_")" D
. D PRNTL
. D MESS
I $D(PSIVFLAG) 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,PRNTL
. S X=$P(^PS(52.7,$P(PSIV,U,2),0),U,4) I X]"" S X=" "_X D PRNTL
G:$D(PSIVFLAG) 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,PRNTL 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 PRNTL
F I=0:0 S I=$O(HYPL(I)) Q:'I S PSIV="" D
. F I=I:0 S PSIV=$O(HYPL(I,PSIV)) Q:PSIV="" S Y="",X=0 D
.. X "F ZZ=0:0 S Y=$O(HYPL(I,PSIV,Y)) Q:Y="""" I Y=""ALL""!(Y=""***"")!(Y[P(16)) S X=X+$P(HYPL(I,PSIV,Y),U),PSIVP=HYPL(I,PSIV,Y) D UPD"
.. I X D HYP
K HYPAD
SOL S X="",$P(X,"=",PSIVRM-1)="" D PRNTL
S X=" " D PRNTL 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^PSIVLABL 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 PRNTL
;
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]"" PRNTL
I $D(^PS(55,DFN,"IV",+ON,3)) S X=$P(^(3),U) D:X]"" PRNTL
S X=P(9) D:X]"" PRNTL
S X=P(11) D:X]"" PRNTL
;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 PRNTL
I $D(^PS(59.5,PSIVSN,4)) S Y=^(4) F PSIV=1:1 S X=$P(Y,U,PSIV) Q:X="" D PRNTL
;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
;S X=PSIV1_"["_PSIVNOL_"]" D PRNTL
S X=PSIV1_"["_PSIVNOL_"]" I $G(IHSEXDT) D OFFSET^PSIVLABL(X,"Do Not Use After: "_IHSEXDT) I $G(PRTFLG)=0 S X=PRTLINE ;PRINT EXP DATE ON LAST LINE
D PRNTL
Q
PRNTL N I 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
TVOL ;
S PSIV=TVOL F X=0:0 S X=$O(^PS(55,DFN,"IV",+ON,"AD",X)) Q:'X S X=X_"^"_^(X,0) S:$P(X,U,4)[P(16)!($P(X,U,4)="")!'PSIV1 PSIV=PSIV+$S($P(^PS(52.6,$P(X,U,2),0),U,10):$P(X,U,3)/$P(^(0),U,10),1:0)
S X="Total Volume: "_(PSIV+.5\1) D PRNTL
Q
SOL1 S X=$S($D(^PS(52.7,$P(PSIV,U,2),0)):$P(^(0),U)_" "_$P(^PS(55,DFN,"IV",+ON,"SOL",+PSIV,0),U,2),1:"**********") Q
HYP ;
I PSIV="*" S X="*** Error in "_$S(I=50.4:"electrolyte",I=52.7:"solution",1:"additive") D PRNTL Q
S PSIVA=$S(I=50.4:PSIV,I=52.7:+$G(^PS(55,DFN,"IV",+ON,"SOL",PSIV,0)),1:+$G(^PS(55,DFN,"IV",+ON,"AD",PSIV,0)))
S X=$S($D(^PS(I,PSIVA,0)):$P(^(0),U),1:"Undefined "_$S(I=50.4:"electrolyte",I=52.7:"solution",1:"additive"))_" "_$S(X<1:"0"_(X+.005\.01/100),1:(X+.005\.01/100))_" "_$P($P(HYPL(I,PSIV,$O(HYPL(I,PSIV,""))),U)," ",2)
D PRNTL
Q
SETP S Y=^PS(55,DFN,"IV",+ON,0) F X=1:1:23 S P(X)=$P(Y,U,X)
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
UPD N X,Y,PSIVEL,PSIVAD
S PSIVEL=$P(PSIVP,"^",2)
I I=50.4 F PSIVAD=0:0 S PSIVAD=$O(HYPLRPT(PSIVEL,"AD",PSIVAD)) Q:'PSIVAD D
.I $D(HYPAD(+PSIVAD)) Q
.S YY=$G(^PS(55,DFN,"IV",+ON,"AD",+PSIVAD,0))
.S HYPAD(+PSIVAD)=""
.I +$P(YY,U,3),(+$P(YY,U,3)'=P(16)) Q
.D UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY)
I I'=50.4 S YY=$G(^PS(55,DFN,"IV",+ON,"AD",+PSIV,0)) D UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY)
Q
BARCODE D PSET^%ZISP
;IHS/MSC/PB - 04/25/12 - added the next line to compute line length -- see note before line tag OFFSET
;I $P($G(^PS(59.5,PSIVSN,9999999)),"^")=1 D OFFSET^PSIVLABL(PSJBCID,"Do Not Use After:")
;IHS/MSC/PB - 2/11/13 - line below modified to to a $G of the variable PRTFLG to prevent errors if the PRTFLG is not defined
;I PRTFLG=0 S PSJBCID=PRTLINE
;I $G(PRTFLG)=0 S PSJBCID=PRTLINE
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
PSIVHYPL ;BIR/PR-PRINT OUT LABELS ;05-May-2014 19:00;DU
+1 ;;5.0; INPATIENT MEDICATIONS ;**58,96,128,178,184,1010,1015,1018**;16 DEC 97;Build 21
+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(50.4 is supported by DBIA 2175.
+8 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+9 ; Modified - IHS/CIA/PLS - 12/05/03 Line SSWARD+4
+10 ;NEEDS DFN, ON AND PSIVNOL (Total number of labels to print) and
+11 ;PSIVCT - $D(PSIVCT) NO COUNT LABEL
+12 ;
+13 ; Modified - IHS/MSC/PB - 4/25/12 to add expiration date to the iv label. Added line tag OFFSET,
+14 ; lines BARCODE+1,2,&3
+15 ; - IHS/MSC/PB - 2/11/13 modified line BARCODE + 3 to use a $G to prevent errors if the PRTFLG variable is not set
+16 ; - IHS/MSC/PB - 2/13/13 modified line RE+7 to set the TEXT1 variable to "_________" if the offset is '>0
+17 ; - IHS/MSC/PB - 3/1/13 modified to incorporate changes made by VA for BCMA project
+18 ; IHS/MSC/PLS - 05/05/14 - Removed modifications at BARCODE+1
SSWARD ;Get patient SS# and ward location
+1 NEW X0,PSJIO,I
+2 SET I=0
FOR
SET I=$ORDER(^%ZIS(2,IOST(0),55,I))
IF 'I
QUIT
SET X0=^(I,0)
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 S VADM(2)=$E(VADM(2),6,9),PSIVWD=$S(+VAIN(4):$P(VAIN(4),U,2),1:"Opt. IV")
+6 DO ENIV^PSJAC
SET VADM(2)=$GET(VA("BID"))
SET PSIVWD=$SELECT(+VAIN(4):$PIECE(VAIN(4),U,2),1:"Opt. IV")
+7 IF PSIVNOL<1
GOTO Q
DO SETP
DO ^PSIVHYP
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
+8 IF PSJIO
IF $GET(PSJIO("FI"))]""
XECUTE PSJIO("FI")
+9 IF $PIECE(PSIVSITE,U,7)
Begin DoDot:1
+10 SET PSIVFLAG=1
SET (LINE,PSIV1)=0
SET PSIV2=PSIVNOL
SET PSIVNOL=0
DO RE
+11 SET PSIVRP=""
SET PSIVRT=""
+12 IF $DATA(^PS(55,DFN,"IV",+ON,.2))
SET PSIVRP=$PIECE(^PS(55,DFN,"IV",+ON,.2),U,3)
Begin DoDot:2
+13 ;QUIT IF "DOSE DUE AT" LINE 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
+14 SET PSIVRT=$PIECE(^PS(51.2,PSIVRP,0),U,1)
+15 SET X="ROUTE: "_PSIVRT
IF X]""
DO PMR
End DoDot:2
+16 SET X="Solution: _______________"
DO PRNTL
SET X="Additive: _______________"
DO PRNTL
+17 SET PSIVNOL=PSIV2
+18 IF 'PSJIO
FOR LINE=LINE+1:1:(PSIVSITE+$PIECE(PSIVSITE,U,16))
WRITE !
+19 IF PSJIO
IF $GET(PSJIO("EL"))]""
XECUTE PSJIO("EL")
End DoDot:1
+20 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
+21 KILL PSIVFLAG,PSIVSH
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 HYPL,LINE,MESS,P16,PDATE,PDOSE,PSIV,PSIVA,PSIV1,PSIV2,PSIVCT,PSIVDOSE,PSIVFLAG,PSIVRM,PSIVWD,TVOL,HYPLPRT,PSIMESS,TEXT1,IHSEXDT
QUIT
RE IF PSIV1
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)=1440/P(15)+.5\1
+1 KILL DO
+2 IF PSJIO
IF $GET(PSJIO("SL"))]""
XECUTE PSJIO("SL")
+3 IF PSIV1
SET PSJBCID=$$BCMA^PSIVBCID(DFN,ON,$DATA(PSIVCT),$GET(PSIV1),$GET(PSIV2),$GET(PSIVNOL))
DO BARCODE
+4 ;IHS/MSC/PB - 4/25/12 - next line computes the IV label expiration date
+5 ;,$P($G(^PS(55,DFN,"IV",+ON,9999999)),U,1)'="" D
IF $PIECE($GET(^PS(59.5,PSIVSN,9999999)),U)=1
Begin DoDot:1
+6 ;IHS/MSC/PB - 2/13/13 modified the line below to set TEXT1 = "___________" if the offset parameter is 0 or null
+7 ;Q:$P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'>0
+8 NEW EXDT,XX1
+9 IF $PIECE($GET(^PS(55,DFN,"IV",+ON,9999999)),U)'>0
SET (IHSEXDT,TEXT1)="________"
QUIT
+10 SET XX1=$PIECE(^PS(55,DFN,"IV",+ON,9999999),U)
SET EXDT=$$FMADD^XLFDT($$DT^XLFDT(),XX1)
+11 SET (IHSEXDT,TEXT1)=$$FMTE^XLFDT(EXDT,"5Z")
+12 ;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
End DoDot:1
+13 ;.S IHSEXDT=TEXT1 ;D OFFSET^PSIVLABL(X,TEXT1)
+14 ;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
+15 ;APSP/PB modified the following line to print the expiration date on the second line.
+16 ;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
+17 ;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)
+18 ;D:$P($G(^PS(59.5,PSIVSN,9999999)),"^")=1&($D(TEXT1)) OFFSET^PSIVLABL(X,TEXT1)
+19 ;I $G(PRTFLG)=0 S X=$G(PRTLINE)
+20 ;D PRNTL
+21 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 PRNTL
+22 SET X=VADM(1)
IF $PIECE(PSIVSITE,U,9)
SET X=X_" "_$SELECT(VAIN(5)]"":VAIN(5),1:"NF")
DO PRNTL
SET X=" "
DO PRNTL
+23 IF $PIECE(PSIVSITE,U,12)
DO TVOL
+24 SET X=""
SET $PIECE(X,"=",PSIVRM-1)=""
DO PRNTL
+25 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),U),1:"*********")_" "_$PIECE(Y,U,2)_" "
IF $PIECE(Y,U,3)]""
SET X=X_" ("_$PIECE(Y,U,3)_")"
Begin DoDot:1
+26 DO PRNTL
+27 DO MESS
End DoDot:1
+28 IF $DATA(PSIVFLAG)
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
+29 DO SOL1
DO PRNTL
+30 SET X=$PIECE(^PS(52.7,$PIECE(PSIV,U,2),0),U,4)
IF X]""
SET X=" "_X
DO PRNTL
End DoDot:1
+31 IF $DATA(PSIVFLAG)
GOTO SOL
+32 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
+33 DO SOL1
DO PRNTL
IF PSIV1
DO UP3^PSIVBCID(DFN,PSJBLN,PSIV,YY)
+34 SET X=$PIECE(^PS(52.7,$PIECE(PSIV,U,2),0),U,4)
IF X]""
SET X=" "_X
DO PRNTL
End DoDot:1
+35 FOR I=0:0
SET I=$ORDER(HYPL(I))
IF 'I
QUIT
SET PSIV=""
Begin DoDot:1
+36 FOR I=I:0
SET PSIV=$ORDER(HYPL(I,PSIV))
IF PSIV=""
QUIT
SET Y=""
SET X=0
Begin DoDot:2
+37 XECUTE "F ZZ=0:0 S Y=$O(HYPL(I,PSIV,Y)) Q:Y="""" I Y=""ALL""!(Y=""***"")!(Y[P(16)) S X=X+$P(HYPL(I,PSIV,Y),U),PSIVP=HYPL(I,PSIV,Y) D UPD"
+38 IF X
DO HYP
End DoDot:2
End DoDot:1
+39 KILL HYPAD
SOL SET X=""
SET $PIECE(X,"=",PSIVRM-1)=""
DO PRNTL
+1 SET X=" "
DO PRNTL
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
+2 IF '$DATA(PSIVDOSE)
SET PSIVDOSE=""
SET X=$PIECE(PSIVDOSE," ",PSIV1)
IF $EXTRACT(X)="."
DO CONVER^PSIVLABL
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 PRNTL
+3 ;
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 PRNTL
+1 IF $DATA(^PS(55,DFN,"IV",+ON,3))
SET X=$PIECE(^(3),U)
IF X]""
DO PRNTL
+2 SET X=P(9)
IF X]""
DO PRNTL
+3 SET X=P(11)
IF X]""
DO PRNTL
+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 PRNTL
+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 PRNTL
+7 ;MSC/IHS/PB - 3/1/13 modified to incorporate changes by VA for BCMA project
+8 ;S X=PSIV1_"["_PSIVNOL_"]" D PRNTL
+9 ;PRINT EXP DATE ON LAST LINE
SET X=PSIV1_"["_PSIVNOL_"]"
IF $GET(IHSEXDT)
DO OFFSET^PSIVLABL(X,"Do Not Use After: "_IHSEXDT)
IF $GET(PRTFLG)=0
SET X=PRTLINE
+10 DO PRNTL
+11 QUIT
PRNTL NEW I
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
TVOL ;
+1 SET PSIV=TVOL
FOR X=0:0
SET X=$ORDER(^PS(55,DFN,"IV",+ON,"AD",X))
IF 'X
QUIT
SET X=X_"^"_^(X,0)
IF $PIECE(X,U,4)[P(16)!($PIECE(X,U,4)="")!'PSIV1
SET PSIV=PSIV+$SELECT($PIECE(^PS(52.6,$PIECE(X,U,2),0),U,10):$PIECE(X,U,3)/$PIECE(^(0),U,10),1:0)
+2 SET X="Total Volume: "_(PSIV+.5\1)
DO PRNTL
+3 QUIT
SOL1 SET X=$SELECT($DATA(^PS(52.7,$PIECE(PSIV,U,2),0)):$PIECE(^(0),U)_" "_$PIECE(^PS(55,DFN,"IV",+ON,"SOL",+PSIV,0),U,2),1:"**********")
QUIT
HYP ;
+1 IF PSIV="*"
SET X="*** Error in "_$SELECT(I=50.4:"electrolyte",I=52.7:"solution",1:"additive")
DO PRNTL
QUIT
+2 SET PSIVA=$SELECT(I=50.4:PSIV,I=52.7:+$GET(^PS(55,DFN,"IV",+ON,"SOL",PSIV,0)),1:+$GET(^PS(55,DFN,"IV",+ON,"AD",PSIV,0)))
+3 SET X=$SELECT($DATA(^PS(I,PSIVA,0)):$PIECE(^(0),U),1:"Undefined "_$SELECT(I=50.4:"electrolyte",I=52.7:"solution",1:"additive"))_" "_$SELECT(X<1:"0"_(X+.005\.01/100),1:(X+.005\.01/100))_" "_$PIECE($PIECE(HYPL(I,PSIV,$ORDER(HYPL(I,PSIV,""))),U),"
",2)
+4 DO PRNTL
+5 QUIT
SETP SET Y=^PS(55,DFN,"IV",+ON,0)
FOR X=1:1:23
SET P(X)=$PIECE(Y,U,X)
+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
UPD NEW X,Y,PSIVEL,PSIVAD
+1 SET PSIVEL=$PIECE(PSIVP,"^",2)
+2 IF I=50.4
FOR PSIVAD=0:0
SET PSIVAD=$ORDER(HYPLRPT(PSIVEL,"AD",PSIVAD))
IF 'PSIVAD
QUIT
Begin DoDot:1
+3 IF $DATA(HYPAD(+PSIVAD))
QUIT
+4 SET YY=$GET(^PS(55,DFN,"IV",+ON,"AD",+PSIVAD,0))
+5 SET HYPAD(+PSIVAD)=""
+6 IF +$PIECE(YY,U,3)
IF (+$PIECE(YY,U,3)'=P(16))
QUIT
+7 DO UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY)
End DoDot:1
+8 IF I'=50.4
SET YY=$GET(^PS(55,DFN,"IV",+ON,"AD",+PSIV,0))
DO UP2^PSIVBCID(DFN,PSJBLN,PSIV,YY)
+9 QUIT
BARCODE DO PSET^%ZISP
+1 ;IHS/MSC/PB - 04/25/12 - added the next line to compute line length -- see note before line tag OFFSET
+2 ;I $P($G(^PS(59.5,PSIVSN,9999999)),"^")=1 D OFFSET^PSIVLABL(PSJBCID,"Do Not Use After:")
+3 ;IHS/MSC/PB - 2/11/13 - line below modified to to a $G of the variable PRTFLG to prevent errors if the PRTFLG is not defined
+4 ;I PRTFLG=0 S PSJBCID=PRTLINE
+5 ;I $G(PRTFLG)=0 S PSJBCID=PRTLINE
+6 IF 'PSJIO
Begin DoDot:1
+7 IF IOBARON]""
WRITE @IOBARON
+8 WRITE PSJBCID
+9 IF IOBAROFF]""
WRITE @IOBAROFF
+10 WRITE !
End DoDot:1
+11 IF PSJIO
Begin DoDot:1
+12 FOR I="SB","SBF"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
+13 WRITE PSJBCID
+14 FOR I="EBF","EB"
IF $GET(PSJIO(I))]""
XECUTE PSJIO(I)
End DoDot:1
+15 QUIT
