PSIVLABL.m

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