- PSIVUDL ;BIR/PR,MLM-IV ORDER INFORMATION FOR UNIT DOSE LABEL ;25 Nov 98 / 9:12 AM
- ;;5.0; INPATIENT MEDICATIONS ;**21,58,110**;16 DEC 97
- ;
- ; 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
- ;
- ;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)
- 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)
- 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
- 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)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVUDL 4949 printed Jan 18, 2025@03:06:24 Page 2
- PSIVUDL ;BIR/PR,MLM-IV ORDER INFORMATION FOR UNIT DOSE LABEL ;25 Nov 98 / 9:12 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**21,58,110**;16 DEC 97
- +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 ;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 WRITE $CHAR(13),?1,$EXTRACT(P("LOG"),1,5)," |",X,?36,"(",$EXTRACT(VADM(1),1),$EXTRACT(VADM(2),6,9),")",?42,"|",$GET(PSJLAT(1)),?52,VADM(1),?88,$JUSTIFY($SELECT(PSJLRB]"":PSJLRB,1:"*NF*"),12)
- +7 if '+PSGLRN
- SET PSGLRN="_____"
- +8 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))
- +9 SET PSJCNT=2
- SET X=0
- SET MSG=""
- SET PSJCONT="See next label for continuation"
- +10 NEW NAME
- +11 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)_" "
- +12 ;*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)
- +13 NEW PSJPRT2
- +14 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
- +15 WRITE ?4,NAME(Y)
- DO NXTLNE(1)
- +16 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",X),0),U,4)
- IF PSJPRT2]""
- WRITE !?7,PSJPRT2
- DO NXTLNE(1)
- End DoDot:1
- +17 IF MSG]""
- SET P("OPI")=MSG_P("OPI")
- if $LENGTH($PIECE(P("OPI"),"^"))>180
- SET $PIECE(P("OPI"),"^")=$EXTRACT($PIECE(P("OPI"),"^"),1,177)_"..."
- +18 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"),"^"))))
- +19 IF P(4)="C"
- WRITE "*CAUTION-CHEMOTHERAPY*"
- if $LENGTH($PIECE(P("OPI"),"^"))
- DO NXTLNE($LENGTH($PIECE(P("OPI"),"^"))>22)
- +20 IF P("OPI")]""
- WRITE ?1,""
- FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
- Begin DoDot:1
- +21 SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
- IF $X+$LENGTH(Y1)>42
- DO NXTLNE($LENGTH($PIECE($PIECE(P("OPI"),"^")," ",Y))>23)
- WRITE ?1
- +22 WRITE Y1," "
- End DoDot:1
- +23 if $X>24
- DO NXTLNE(1)
- +24 IF $DATA(PSJLAT(PSJCNT+1))
- FOR
- if '$DATA(PSJLAT(PSJCNT+1))
- QUIT
- Begin DoDot:1
- +25 IF PSJCNT#5=0
- WRITE ?1,PSJCONT
- DO NXTLNE(2)
- WRITE ?1
- QUIT
- +26 DO NXTLNE($DATA(PSJLAT(PSJCNT+2)))
- End DoDot:1
- +27 IF PSJCNT#5>0
- FOR
- if PSJCNT#5=0
- QUIT
- DO NXTLNE(0)
- +28 WRITE ?24,"RPH:",PSJRPH,?33," RN:",PSGLRN
- DO NXTLNE($DATA(PSJLAT(PSJCNT+1)))
- WRITE !
- +29 ;* 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 if PSJCNT=2
- WRITE ?42,PSGLST
- WRITE ?43,"|",$GET(PSJLAT(PSJCNT))
- IF PSJCNT=2
- WRITE ?52,$PIECE(VADM(2),U,2),?70,$EXTRACT($$ENDTC^PSGMI(+VADM(3)),1,8)," (",VADM(4),")",?85,$JUSTIFY($SELECT(PSJTM]"":PSJTM,1:"NOT FOUND"),15)
- +3 IF PSJCNT=3
- WRITE ?52,$SELECT(VADM(5)]"":$PIECE(VADM(5),U,2),1:"____"),?65,"DX: ",VAIN(9)
- +4 IF PSJCNT=4
- IF PSJLDT
- SET Y=PSJLR
- Begin DoDot:1
- +5 WRITE ?52,$$ENDTC^PSGMI(PSJLDT)
- +6 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
- +7 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)
- +8 WRITE !,?1
- SET PSJCNT=PSJCNT+1
- IF NL=2
- WRITE !,?1
- SET NL=0
- +9 IF PSJCNT#5=0
- IF NL
- WRITE ?1,PSJCONT
- DO NXTLNE(2)
- +10 QUIT