PSIVLABR.m

PSIVLABR ;BIR/PR-REPRINT LABELS ;03-Apr-2013 14:21;PLS

 ;;5.0; INPATIENT MEDICATIONS ;**58,82,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 - 03/31/04 - Line DEM+4

 ;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,

 ;            IHS/MSC/PB - 12/10/12 check for the existance of the variable TEXT1

 ;          - IHS/MSC/PB - 2/13/13 modified line RE+6 to set TEXT1 = "_______" if the offset is not greater than zero

 ;

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

 ;

 ;;NEW PSIVNOL,PSIV1 S (PSIVNOL,PSIV1)=1

 NEW PSIV1 S PSIV1=1

 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")

 ;PSJRPHD is defined in REPRT^PSIVLBRP so header only print once.

 I $P(PSIVSITE,U,7),'$D(PSJRPHD) 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" 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

 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)+1

 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 S PSIV1=1,LINE=0 D RE D

 . 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,PSIVCT,PSIVWD,P16,LINE,MESS,PSIV2,PSIVFLAG,PSIVRM,PSIV1,PDOSE,PDATE,XX1,XX2,BAG,CX,PSIMESS,TEXT1 Q

RE ;

 ;NEED THE CODE BELOW?

 ;;I PSIV1,P(4)="A"!(P(5)=0) 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 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

 .;IHS/MSC/PB - 2/13/13 modified the line below to set TEXT1 = "________" if the offset is '>0

 .;Q:$P($G(^PS(55,DFN,"IV",+ON,9999999)),"^")'>0

 .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,MESS

 G:$D(PSIVFLAG) SOL

 F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"AD",PSIV)) Q:'PSIV  S Y=^(PSIV,0),X=$S($D(^PS(52.6,+Y,0)):$P(^(0),U),1:"********")_" "_$P(Y,U,2) D

 . D P,MESS

SOL F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSIV)) Q:'PSIV  S PSIV=PSIV_"^"_+^(PSIV,0),YY=^(0) D

 . D SOL1,P

 . 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

 ;S X=PSIV1_"["_$S(PSIV1:PSIVNOL,1:PSIV2)_"]"_"  "_$S('PSIV1:PSIVNOW,1:"") D P

 ;MSC/IHS/PB - 3/1/13 modified to incorporate VA changes for BCMA project

 ;S X=PSIVBAG D P

 ;IHS KCF VAOIT  modified the following line to print the expiration date to print on the iv label IF EXP DATE PRINTS TO RIGHT OF LABEL COUNT

 S X=PSIVBAG I $G(TEXT1)'="" D OFFSET^PSIVLABL(X,"Do Not Use After: "_TEXT1) S X=$G(PRTLINE)

 D P

 ;IHS/MSC/PB - 04/25/12 - modified the following line to print the expiration date to print on the iv label

 ;IHS/MSC/PB - 12/10/12 - modified the line below to check for TEXT1 to exist.

 ;D OFFSET^PSIVLABL("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P

 ;I $G(TEXT1)'="" D OFFSET^PSIVLABL("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P

 ;MSC/IHS/PB - 3/1/13 end of modification

 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,"IVBCMA",PSJIDNO,"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

PSIVLABR  ;BIR/PR-REPRINT LABELS ;03-Apr-2013 14:21;PLS

 +1       ;;5.0; INPATIENT MEDICATIONS ;**58,82,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       ;

 +9       ; Modified - IHS/CIA/PLS - 03/31/04 - Line DEM+4

 +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      ;            IHS/MSC/PB - 12/10/12 check for the existance of the variable TEXT1

 +18      ;          - IHS/MSC/PB - 2/13/13 modified line RE+6 to set TEXT1 = "_______" if the offset is not greater than zero

 +19      ;

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       ;;NEW PSIVNOL,PSIV1 S (PSIVNOL,PSIV1)=1

 +9        NEW PSIV1

           SET PSIV1=1

 +10       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

 +11       IF PSJIO

               IF $GET(PSJIO("FI"))]""

                   XECUTE PSJIO("FI")

 +12      ;PSJRPHD is defined in REPRT^PSIVLBRP so header only print once.

 +13       IF $PIECE(PSIVSITE,U,7)

               IF '$DATA(PSJRPHD)

                   Begin DoDot:1

 +14                   SET PSIVFLAG=1

                       SET (LINE,PSIV1)=0

                       SET PSIV2=PSIVNOL

                       SET PSIVNOL=0

                       DO RE

 +15                   SET PSIVRP=""

                       SET PSIVRT=""

 +16                   IF $DATA(^PS(55,DFN,"IV",+ON,.2))

                           SET PSIVRP=$PIECE(^PS(55,DFN,"IV",+ON,.2),U,3)

                           Begin DoDot:2

 +17      ;QUIT 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 

 +18                           SET PSIVRT=$PIECE(^PS(51.2,PSIVRP,0),U,1)

 +19                           SET X="ROUTE: "_PSIVRT

                               IF X]""

                                   DO PMR

                           End DoDot:2

 +20                   SET X="Solution: _______________"

                       DO P

                       SET X="Additive: _______________"

                       DO P

 +21                   SET PSIVNOL=PSIV2

 +22                   IF 'PSJIO

                           FOR LINE=LINE+1:1:(PSIVSITE+$PIECE(PSIVSITE,U,16))

                               WRITE !

 +23                   IF PSJIO

                           IF $GET(PSJIO("EL"))]""

                               XECUTE PSJIO("EL")

                   End DoDot:1

 +24      ;;I '$D(PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">PSIVCT) D NOW^%DTC S Y=%,$PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">P(^PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">PS(55,DFN,"IV",+ON,9),U,1,2)=Y_"^"_PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">PSIVNOL,$PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">P(^(9),U,3)=$PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">P(^(9),U,3)+PSIVLABR_source.html#xP">PSIVLABR_source.html#xPSIVLABR_source.html#xP">P">PSIVLABR_source.html#xP">PSIVNOL

 +25       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)+1

 +26       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      SET PSIV1=1

           SET LINE=0

           DO RE

           Begin DoDot:1

 +1            IF $DATA(PSIVFLAG)

                   QUIT 

 +2            IF 'PSJIO

                   FOR LINE=LINE+1:1:(PSIVSITE+$PIECE(PSIVSITE,U,16))

                       WRITE !

 +3            IF PSJIO

                   IF $GET(PSJIO("EL"))]""

                       XECUTE PSJIO("EL")

           End DoDot:1

 +4        IF PSJIO

               IF $GET(PSJIO("FE"))]""

                   XECUTE PSJIO("FE")

 +5        IF '$DATA(PSIVCT)

               DO ^PSIVSTAT

Q          KILL PSIV,PSIVDOSE,PSIVCT,PSIVWD,P16,LINE,MESS,PSIV2,PSIVFLAG,PSIVRM,PSIV1,PDOSE,PDATE,XX1,XX2,BAG,CX,PSIMESS,TEXT1

           QUIT 

RE        ;

 +1       ;NEED THE CODE BELOW?

 +2       ;;I PSIV1,P(4)="A"!(P(5)=0) 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

 +3        IF PSJIO

               IF $GET(PSJIO("SL"))]""

                   XECUTE PSJIO("SL")

 +4        IF PSIV1

               DO BARCODE

 +5       ;IHS/MSC/PB - 04/25/12 - next line computes the IV label expiration date

 +6       ;,$P($G(^PS(55,DFN,"IV",+ON,9999999)),U)'="" D

           IF $PIECE($GET(^PS(59.5,PSIVSN,9999999)),U)=1

               Begin DoDot:1

 +7                NEW EXDT,XX1

 +8       ;IHS/MSC/PB - 2/13/13 modified the line below to set TEXT1 = "________" if the offset is '>0

 +9       ;Q:$P($G(^PS(55,DFN,"IV",+ON,9999999)),"^")'>0

 +10               IF $PIECE($GET(^PS(55,DFN,"IV",+ON,9999999)),U)'>0

                       SET TEXT1="________"

                       QUIT 

 +11               SET XX1=$PIECE(^PS(55,DFN,"IV",+ON,9999999),U)

                   SET EXDT=$$FMADD^XLFDT($$DT^XLFDT(),XX1)

 +12               SET TEXT1=$$FMTE^XLFDT(EXDT,"5Z")

               End DoDot:1

 +13       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

 +14       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

 +15       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

 +16                   DO P

                       DO MESS

                   End DoDot:1

 +17       IF $DATA(PSIVFLAG)

               GOTO SOL

 +18       FOR PSIV=0:0

               SET PSIV=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"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)

               Begin DoDot:1

 +19               DO P

                   DO MESS

               End DoDot:1

SOL        FOR PSIV=0:0

               SET PSIV=$ORDER(^PS(55,DFN,"IVBCMA",PSJIDNO,"SOL",PSIV))

               IF 'PSIV

                   QUIT 

               SET PSIV=PSIV_"^"_+^(PSIV,0)

               SET YY=^(0)

               Begin DoDot:1

 +1                DO SOL1

                   DO P

 +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       ;S X=PSIV1_"["_$S(PSIV1:PSIVNOL,1:PSIV2)_"]"_"  "_$S('PSIV1:PSIVNOW,1:"") D P

 +8       ;MSC/IHS/PB - 3/1/13 modified to incorporate VA changes for BCMA project

 +9       ;S X=PSIVBAG D P

 +10      ;IHS KCF VAOIT  modified the following line to print the expiration date to print on the iv label IF EXP DATE PRINTS TO RIGHT OF LABEL COUNT

 +11       SET X=PSIVBAG

           IF $GET(TEXT1)'=""

               DO OFFSET^PSIVLABL(X,"Do Not Use After: "_TEXT1)

               SET X=$GET(PRTLINE)

 +12       DO P

 +13      ;IHS/MSC/PB - 04/25/12 - modified the following line to print the expiration date to print on the iv label

 +14      ;IHS/MSC/PB - 12/10/12 - modified the line below to check for TEXT1 to exist.

 +15      ;D OFFSET^PSIVLABL("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P

 +16      ;I $G(TEXT1)'="" D OFFSET^PSIVLABL("Do Not Use After:",TEXT1) S X=$G(PRTLINE) D P

 +17      ;MSC/IHS/PB - 3/1/13 end of modification

 +18       QUIT 

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 

SOL1       SET X=$SELECT($DATA(^PS(52.7,$PIECE(PSIV,U,2),0)):$PIECE(^(0),"^")_" "_$PIECE(^PS(55,DFN,"IVBCMA",PSJIDNO,"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"