PSIVUDL ;BIR/PR,MLM-IV ORDER INFORMATION FOR UNIT DOSE LABEL ;28-Feb-2014 14:12;DU
;;5.0; INPATIENT MEDICATIONS ;**21,58,110,1015,1018**;16 DEC 97;Build 21
;
; References to ^PS(52.6 supported by DBIA #1231
; References to ^PS(52.7 supported by DBIA #2173
; References to ^PS(55 supported by DBIA #2191
;
; Modified - IHS/CIA/PLS - 12/05/03 - Line ENP+4 and NXTLNE+2
;Needs DFN and PSJORD
EN(DFN,ON,PSJLWD,PSJLRB) ; Entry to print MAR label for all types of IV orders.
N PSJLABEL,VAIN,VADM S (PSJACNWP,PSJLABEL)=1 D ENIV^PSJAC
S PSJTM=$S(PSJLRB]"":$P($G(^PS(57.7,+PSJLWD,1,+$O(^PS(57.7,"AWRT",+PSJLWD,PSJLRB,0)),0)),U),1:""),PSJWGN=$P($G(^PS(57.5,+$O(^PS(57.5,"AB",+PSJLWD,0)),0)),U)
K PSJLAT,ON55 D @$S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA(DFN,ON)") S (MSG,PSJRPH,PSJLDT,PSJLR)="" S:ON["V" X=$G(^PS(55,DFN,"IV",+ON,7)),PSJLDT=+X,PSJLR=$P(X,U,2)
I ON["P",(P("OPI")=""),$O(^PS(53.1,+ON,12,0)) F X=0:0 S X=$O(^PS(53.1,+ON,12,X)) Q:'X!($L(P("OPI"))>180) S P("OPI")=P("OPI")_" "_$G(^(X,0))
S PSJLAT=P(11),PSGLST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I PSGLST'="O" S PSGLST=$S(P(9)["PRN":"P",1:"C")
S:ON["P" PSGLST=""
F X="LOG",2,3 S:P(X) P(X)=$$ENDTC1^PSGMI(P(X))
D RPHINIT^PSGMIV(.PSJRPH)
S X=P(17),(PSJLAT(1),PSJLAT(2),PSJLAT(4),PSJLAT(5))=$S(X="D"!(X="E"):"****",1:""),PSJLAT(3)=$S(X="D":"DC'D",X="E":"EX'D",1:""),PSJLAT(0)=$S(X="D":0,X="E":0,1:$L(PSJLAT,"-"))
I PSJLAT(0) D
.F X=1:1:5 S PSJLAT(X)=""
.I PSJLAT(0)=1 S PSJLAT(3)=$P(PSJLAT,"-") Q
.I PSJLAT(0)=2 S PSJLAT(1)=$P(PSJLAT,"-"),PSJLAT(5)=$P(PSJLAT,"-",2) Q
.I PSJLAT(0)=3 S PSJLAT(1)=$P(PSJLAT,"-"),PSJLAT(3)=$P(PSJLAT,"-",2),PSJLAT(5)=$P(PSJLAT,"-",3) Q
.F X=1:1:PSJLAT(0) S PSJLAT(X)=$P(PSJLAT,"-",X)
;
ENP ; Print MAR label for IV order.
S PSGLRN=$S(ON["P":$G(^PS(53.1,+ON,4)),1:$G(^PS(55,DFN,"IV",+ON,4)))
I $G(DFN),$G(ON) N PSGLREN S PSGLREN=+$$LASTREN^PSJLMPRI(DFN,ON)
N PSGLRNDT S PSGLRNDT=$P(PSGLRN,"^",2),PSGLRN=+PSGLRN I PSGLRNDT,$G(PSGLREN) I $G(PSGLREN)>PSGLRNDT S PSGLRN=0
I ON["P",P(2)="",+PSGLRN S X="P E N D I N G"
E S X=$S(P(2)]"":$E(P(2),1,5)_$E(P(2),9,14),1:" ")_" |"_P(3)
; IHS/CIA/PLS - 12/05/03 - Commented out next line and changed from SSN to HRN
;W $C(13),?1,$E(P("LOG"),1,5)," |",X,?36,"(",$E(VADM(1),1),$E(VADM(2),6,9),")",?42,"|",$G(PSJLAT(1)),?52,VADM(1),?88,$J($S(PSJLRB]"":PSJLRB,1:"*NF*"),12)
;W $C(13),?1,$E(P("LOG"),1,5)," |",X,?36,"(",$G(PSJPBID),")",?42,"|",$G(PSJLAT(1)),?52,VADM(1),?88,$J($S(PSJLRB]"":PSJLRB,1:"*NF*"),12)
W $C(13),?1,$E(P("LOG"),1,5)," |",X,?36,"(",$S($G(PSJPBID):PSJPBID,$G(PSGLBID):PSGLBID,$G(PSGLSSN):PSGLSSN,1:$$HRN^AUPNPAT(DFN,$G(DUZ(2)))),")",?42,"|",$G(PSJLAT(1)),?52,VADM(1),?88,$J($S(PSJLRB]"":PSJLRB,1:"*NF*"),12)
S:'+PSGLRN PSGLRN="_____"
I +PSGLRN,$D(^VA(200,+PSGLRN,0))#2 S X=^(0),X=$S($P(X,"^",2)]"":$P(X,"^",2),1:$P(X,"^")),PSGLRN=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))
S PSJCNT=2,X=0,MSG="",PSJCONT="See next label for continuation"
NEW NAME
W ! F X=0:0 S X=$O(DRG("AD",X)) Q:'X D NAME^PSIVUTL(DRG("AD",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W ?1,NAME(Y) D NXTLNE(1) S:$P($G(^PS(52.6,+DRG("AD",+X),0)),U,9)]"" MSG=MSG_$P($G(^(0)),U,9)_" "
;*W:$G(DRG("SOL",0)) ?1,"in " F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W ?4,NAME(Y) D NXTLNE(1)
NEW PSJPRT2
W:$G(DRG("SOL",0)) ?1,"in " F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y D
. W ?4,NAME(Y) D NXTLNE(1)
. S PSJPRT2=$P(^PS(52.7,+DRG("SOL",X),0),U,4) I PSJPRT2]"" W !?7,PSJPRT2 D NXTLNE(1)
I MSG]"" S P("OPI")=MSG_P("OPI") S:$L($P(P("OPI"),"^"))>180 $P(P("OPI"),"^")=$E($P(P("OPI"),"^"),1,177)_"..."
W ?1,$P(P("MR"),U,2)," ",P(9)," ",P(8) I P("OPI")]""!$D(PSJLAT(PSJCNT+1))!(P(4)="C") D NXTLNE($S($L($P(P("OPI"),"^"))>22:1,P(4)'="C":0,1:$L($P(P("OPI"),"^"))))
I P(4)="C" W "*CAUTION-CHEMOTHERAPY*" D:$L($P(P("OPI"),"^")) NXTLNE($L($P(P("OPI"),"^"))>22)
I P("OPI")]"" W ?1,"" F Y=1:1:$L($P(P("OPI"),"^")," ") D
.S Y1=$P($P(P("OPI"),"^")," ",Y) I $X+$L(Y1)>42 D NXTLNE($L($P($P(P("OPI"),"^")," ",Y))>23) W ?1
.W Y1," "
D:$X>24 NXTLNE(1)
I $D(PSJLAT(PSJCNT+1)) F Q:'$D(PSJLAT(PSJCNT+1)) D
.I PSJCNT#5=0 W ?1,PSJCONT D NXTLNE(2) W ?1 Q
.D NXTLNE($D(PSJLAT(PSJCNT+2)))
I PSJCNT#5>0 F Q:PSJCNT#5=0 D NXTLNE(0)
W ?24,"RPH:",PSJRPH,?33," RN:",PSGLRN D NXTLNE($D(PSJLAT(PSJCNT+1))) W !
;* W ?24,"RPH:",$S(PSJRPH]"":PSJRPH,1:"_____"),?33," RN:_____" D NXTLNE($D(PSJLAT(PSJCNT+1))) W !
DONE ;
K DRG,MSG,NL,ON55,PSJTM,P,PSJLAT,PSJRPH,PSJACNWP,PSJCNT,PSJLDT,PSJLR,PSJTM,PSJWGN,X,Y,Y1
Q
NXTLNE(NL) ; Print info to right of drug (x=line number,NL=new label)
N Y
; IHS/CIA/PLS - 12/05/03 - Comment out next line and changed from SSN to HRN
;W:PSJCNT=2 ?42,PSGLST W ?43,"|",$G(PSJLAT(PSJCNT)) I PSJCNT=2 W ?52,$P(VADM(2),U,2),?70,$E($$ENDTC^PSGMI(+VADM(3)),1,8)," (",VADM(4),")",?85,$J($S(PSJTM]"":PSJTM,1:"NOT FOUND"),15)
W:PSJCNT=2 ?42,PSGLST W ?43,"|",$G(PSJLAT(PSJCNT)) I PSJCNT=2 W ?52,$G(PSJPPID),?70,$E($$ENDTC^PSGMI(+VADM(3)),1,8)," (",VADM(4),")",?85,$J($S(PSJTM]"":PSJTM,1:"NOT FOUND"),15)
I PSJCNT=3 W ?52,$S(VADM(5)]"":$P(VADM(5),U,2),1:"____"),?65,"DX: ",VAIN(9)
I PSJCNT=4,PSJLDT S Y=PSJLR D
.W ?52,$$ENDTC^PSGMI(PSJLDT)
.W ?77,$S(Y="N":"NEW ",Y="R":"RENEWAL ",1:""),"ORDER ",$S(Y="AD":"AUTO-DC'ED",Y="N":"",Y="E":"EDITED",Y="DE":"DC'ED (EDIT)",Y["D":"DISCONTINUED",Y="H1":"ON HOLD",Y="H0":"OFF OF HOLD",Y="ARI":"AUTO-REINSTATED",Y="RI":"REINSTATED",1:"")
I PSJCNT=5 W ?52,$S(PSJWGN]"":$E(PSJWGN,1,21),1:"NOT FOUND"),?79,$J($S($P(PSJLWD,U,2)]"":$P(PSJLWD,U,2),1:"NOT FOUND"),21)
W !,?1 S PSJCNT=PSJCNT+1 I NL=2 W !,?1 S NL=0
I PSJCNT#5=0,NL W ?1,PSJCONT D NXTLNE(2)
Q
PSIVUDL ;BIR/PR,MLM-IV ORDER INFORMATION FOR UNIT DOSE LABEL ;28-Feb-2014 14:12;DU
+1 ;;5.0; INPATIENT MEDICATIONS ;**21,58,110,1015,1018**;16 DEC 97;Build 21
+2 ;
+3 ; References to ^PS(52.6 supported by DBIA #1231
+4 ; References to ^PS(52.7 supported by DBIA #2173
+5 ; References to ^PS(55 supported by DBIA #2191
+6 ;
+7 ; Modified - IHS/CIA/PLS - 12/05/03 - Line ENP+4 and NXTLNE+2
+8 ;Needs DFN and PSJORD
EN(DFN,ON,PSJLWD,PSJLRB) ; Entry to print MAR label for all types of IV orders.
+1 NEW PSJLABEL,VAIN,VADM
SET (PSJACNWP,PSJLABEL)=1
DO ENIV^PSJAC
+2 SET PSJTM=$SELECT(PSJLRB]"":$PIECE($GET(^PS(57.7,+PSJLWD,1,+$ORDER(^PS(57.7,"AWRT",+PSJLWD,PSJLRB,0)),0)),U),1:"")
SET PSJWGN=$PIECE($GET(^PS(57.5,+$ORDER(^PS(57.5,"AB",+PSJLWD,0)),0)),U)
+3 KILL PSJLAT,ON55
DO @$SELECT(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA(DFN,ON)")
SET (MSG,PSJRPH,PSJLDT,PSJLR)=""
IF ON["V"
SET X=$GET(^PS(55,DFN,"IV",+ON,7))
SET PSJLDT=+X
SET PSJLR=$PIECE(X,U,2)
+4 IF ON["P"
IF (P("OPI")="")
IF $ORDER(^PS(53.1,+ON,12,0))
FOR X=0:0
SET X=$ORDER(^PS(53.1,+ON,12,X))
IF 'X!($LENGTH(P("OPI"))>180)
QUIT
SET P("OPI")=P("OPI")_" "_$GET(^(X,0))
+5 SET PSJLAT=P(11)
SET PSGLST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF PSGLST'="O"
SET PSGLST=$SELECT(P(9)["PRN":"P",1:"C")
+6 IF ON["P"
SET PSGLST=""
+7 FOR X="LOG",2,3
IF P(X)
SET P(X)=$$ENDTC1^PSGMI(P(X))
+8 DO RPHINIT^PSGMIV(.PSJRPH)
+9 SET X=P(17)
SET (PSJLAT(1),PSJLAT(2),PSJLAT(4),PSJLAT(5))=$SELECT(X="D"!(X="E"):"****",1:"")
SET PSJLAT(3)=$SELECT(X="D":"DC'D",X="E":"EX'D",1:"")
SET PSJLAT(0)=$SELECT(X="D":0,X="E":0,1:$LENGTH(PSJLAT,"-"))
+10 IF PSJLAT(0)
Begin DoDot:1
+11 FOR X=1:1:5
SET PSJLAT(X)=""
+12 IF PSJLAT(0)=1
SET PSJLAT(3)=$PIECE(PSJLAT,"-")
QUIT
+13 IF PSJLAT(0)=2
SET PSJLAT(1)=$PIECE(PSJLAT,"-")
SET PSJLAT(5)=$PIECE(PSJLAT,"-",2)
QUIT
+14 IF PSJLAT(0)=3
SET PSJLAT(1)=$PIECE(PSJLAT,"-")
SET PSJLAT(3)=$PIECE(PSJLAT,"-",2)
SET PSJLAT(5)=$PIECE(PSJLAT,"-",3)
QUIT
+15 FOR X=1:1:PSJLAT(0)
SET PSJLAT(X)=$PIECE(PSJLAT,"-",X)
End DoDot:1
+16 ;
ENP ; Print MAR label for IV order.
+1 SET PSGLRN=$SELECT(ON["P":$GET(^PS(53.1,+ON,4)),1:$GET(^PS(55,DFN,"IV",+ON,4)))
+2 IF $GET(DFN)
IF $GET(ON)
NEW PSGLREN
SET PSGLREN=+$$LASTREN^PSJLMPRI(DFN,ON)
+3 NEW PSGLRNDT
SET PSGLRNDT=$PIECE(PSGLRN,"^",2)
SET PSGLRN=+PSGLRN
IF PSGLRNDT
IF $GET(PSGLREN)
IF $GET(PSGLREN)>PSGLRNDT
SET PSGLRN=0
+4 IF ON["P"
IF P(2)=""
IF +PSGLRN
SET X="P E N D I N G"
+5 IF '$TEST
SET X=$SELECT(P(2)]"":$EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14),1:" ")_" |"_P(3)
+6 ; IHS/CIA/PLS - 12/05/03 - Commented out next line and changed from SSN to HRN
+7 ;W $C(13),?1,$E(P("LOG"),1,5)," |",X,?36,"(",$E(VADM(1),1),$E(VADM(2),6,9),")",?42,"|",$G(PSJLAT(1)),?52,VADM(1),?88,$J($S(PSJLRB]"":PSJLRB,1:"*NF*"),12)
+8 ;W $C(13),?1,$E(P("LOG"),1,5)," |",X,?36,"(",$G(PSJPBID),")",?42,"|",$G(PSJLAT(1)),?52,VADM(1),?88,$J($S(PSJLRB]"":PSJLRB,1:"*NF*"),12)
+9 WRITE $CHAR(13),?1,$EXTRACT(P("LOG"),1,5)," |",X,?36,"(",$SELECT($GET(PSJPBID):PSJPBID,$GET(PSGLBID):PSGLBID,$GET(PSGLSSN):PSGLSSN,1:$$HRN^AUPNPAT(DFN,$GET(DUZ(2)))),")",?42,"|",$GET(PSJLAT(1)),?52,VADM(1),?88,$JUSTIFY(...
... $SELECT(PSJLRB]"":PSJLRB,1:"*NF*"),12)
+10 IF '+PSGLRN
SET PSGLRN="_____"
+11 IF +PSGLRN
IF $DATA(^VA(200,+PSGLRN,0))#2
SET X=^(0)
SET X=$SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:$PIECE(X,"^"))
SET PSGLRN=$SELECT(X'[",":X,1:$EXTRACT(X,$FIND(X,","))_$EXTRACT(X))
+12 SET PSJCNT=2
SET X=0
SET MSG=""
SET PSJCONT="See next label for continuation"
+13 NEW NAME
+14 WRITE !
FOR X=0:0
SET X=$ORDER(DRG("AD",X))
IF 'X
QUIT
DO NAME^PSIVUTL(DRG("AD",X),47,.NAME,1)
FOR Y=0:0
SET Y=$ORDER(NAME(Y))
IF 'Y
QUIT
WRITE ?1,NAME(Y)
DO NXTLNE(1)
IF $PIECE($GET(^PS(52.6,+DRG("AD",+X),0)),U,9)]""
SET MSG=MSG_$PIECE($GET(^(0)),U,9)_" "
+15 ;*W:$G(DRG("SOL",0)) ?1,"in " F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W ?4,NAME(Y) D NXTLNE(1)
+16 NEW PSJPRT2
+17 IF $GET(DRG("SOL",0))
WRITE ?1,"in "
FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
IF 'X
QUIT
DO NAME^PSIVUTL(DRG("SOL",X),47,.NAME,1)
FOR Y=0:0
SET Y=$ORDER(NAME(Y))
IF 'Y
QUIT
Begin DoDot:1
+18 WRITE ?4,NAME(Y)
DO NXTLNE(1)
+19 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",X),0),U,4)
IF PSJPRT2]""
WRITE !?7,PSJPRT2
DO NXTLNE(1)
End DoDot:1
+20 IF MSG]""
SET P("OPI")=MSG_P("OPI")
IF $LENGTH($PIECE(P("OPI"),"^"))>180
SET $PIECE(P("OPI"),"^")=$EXTRACT($PIECE(P("OPI"),"^"),1,177)_"..."
+21 WRITE ?1,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)
IF P("OPI")]""!$DATA(PSJLAT(PSJCNT+1))!(P(4)="C")
DO NXTLNE($SELECT($LENGTH($PIECE(P("OPI"),"^"))>22:1,P(4)'="C":0,1:$LENGTH($PIECE(P("OPI"),"^"))))
+22 IF P(4)="C"
WRITE "*CAUTION-CHEMOTHERAPY*"
IF $LENGTH($PIECE(P("OPI"),"^"))
DO NXTLNE($LENGTH($PIECE(P("OPI"),"^"))>22)
+23 IF P("OPI")]""
WRITE ?1,""
FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
Begin DoDot:1
+24 SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
IF $X+$LENGTH(Y1)>42
DO NXTLNE($LENGTH($PIECE($PIECE(P("OPI"),"^")," ",Y))>23)
WRITE ?1
+25 WRITE Y1," "
End DoDot:1
+26 IF $X>24
DO NXTLNE(1)
+27 IF $DATA(PSJLAT(PSJCNT+1))
FOR
IF '$DATA(PSJLAT(PSJCNT+1))
QUIT
Begin DoDot:1
+28 IF PSJCNT#5=0
WRITE ?1,PSJCONT
DO NXTLNE(2)
WRITE ?1
QUIT
+29 DO NXTLNE($DATA(PSJLAT(PSJCNT+2)))
End DoDot:1
+30 IF PSJCNT#5>0
FOR
IF PSJCNT#5=0
QUIT
DO NXTLNE(0)
+31 WRITE ?24,"RPH:",PSJRPH,?33," RN:",PSGLRN
DO NXTLNE($DATA(PSJLAT(PSJCNT+1)))
WRITE !
+32 ;* W ?24,"RPH:",$S(PSJRPH]"":PSJRPH,1:"_____"),?33," RN:_____" D NXTLNE($D(PSJLAT(PSJCNT+1))) W !
DONE ;
+1 KILL DRG,MSG,NL,ON55,PSJTM,P,PSJLAT,PSJRPH,PSJACNWP,PSJCNT,PSJLDT,PSJLR,PSJTM,PSJWGN,X,Y,Y1
+2 QUIT
NXTLNE(NL) ; Print info to right of drug (x=line number,NL=new label)
+1 NEW Y
+2 ; IHS/CIA/PLS - 12/05/03 - Comment out next line and changed from SSN to HRN
+3 ;W:PSJCNT=2 ?42,PSGLST W ?43,"|",$G(PSJLAT(PSJCNT)) I PSJCNT=2 W ?52,$P(VADM(2),U,2),?70,$E($$ENDTC^PSGMI(+VADM(3)),1,8)," (",VADM(4),")",?85,$J($S(PSJTM]"":PSJTM,1:"NOT FOUND"),15)
+4 IF PSJCNT=2
WRITE ?42,PSGLST
WRITE ?43,"|",$GET(PSJLAT(PSJCNT))
IF PSJCNT=2
WRITE ?52,$GET(PSJPPID),?70,$EXTRACT($$ENDTC^PSGMI(+VADM(3)),1,8)," (",VADM(4),")",?85,$JUSTIFY($SELECT(PSJTM]"":PSJTM,1:"NOT FOUND"),15)
+5 IF PSJCNT=3
WRITE ?52,$SELECT(VADM(5)]"":$PIECE(VADM(5),U,2),1:"____"),?65,"DX: ",VAIN(9)
+6 IF PSJCNT=4
IF PSJLDT
SET Y=PSJLR
Begin DoDot:1
+7 WRITE ?52,$$ENDTC^PSGMI(PSJLDT)
+8 WRITE ?77,$SELECT(Y="N":"NEW ",Y="R":"RENEWAL ",1:""),"ORDER ",$SELECT(Y="AD":"AUTO-DC'ED",Y="N":"",Y="E":"EDITED",Y="DE":"DC'ED (EDIT)",Y["D":"DISCONTINUED",Y="H1":"ON HOLD",Y="H0":"OFF OF HOLD",Y="ARI":"AUTO-REINSTATED",Y="RI":"RE
INSTATED",1:"")
End DoDot:1
+9 IF PSJCNT=5
WRITE ?52,$SELECT(PSJWGN]"":$EXTRACT(PSJWGN,1,21),1:"NOT FOUND"),?79,$JUSTIFY($SELECT($PIECE(PSJLWD,U,2)]"":$PIECE(PSJLWD,U,2),1:"NOT FOUND"),21)
+10 WRITE !,?1
SET PSJCNT=PSJCNT+1
IF NL=2
WRITE !,?1
SET NL=0
+11 IF PSJCNT#5=0
IF NL
WRITE ?1,PSJCONT
DO NXTLNE(2)
+12 QUIT
