PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;03-Apr-2012 10:34;PLS
;;5.0; INPATIENT MEDICATIONS ;**4,20,21,28,58,1013,111,131,145,1014**;16 DEC 97;Build 62
;
; Reference to ^PS(55 supported by DBIA #2191.
; Reference to ^PS(52.7 supported by DBIA #2173.
; Modified - IHS/MSC/PLS - 10/12/2011 - Line PRTIV+20, L+2
;
START ;*** Read IV orders
S ON=""
F PSGMARED=PSGPLS-.0001:0 S PSGMARED=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED)) Q:'PSGMARED F S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON)) Q:ON="" D IV
Q
IV ;*** Sort IV orders for 24 Hrs MAR.
K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB
Q:P(2)>PSGPLF
S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X="IVPB":1,1:0))
S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
S QST=$S(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
N PSGMARWC ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
S PSGMARWC=PSGMARWN
I $G(DRG) S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_ON_"V" D
. N A
. S A=$G(^PS(55,PSGP,"IV",+ON,"DSS")) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
. . N X,X1,Y
. . D SPN^PSGMAR0
. . Q
. . ;
. I PSGSS="P" S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by PATIENT
. I PSGSS="L" Q:((PSGINWDG="")&(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by clinic group
. I PSGSS="C" Q:((PSGINWD="")&(PSGMARWN'["C!")) I ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by Clinic
. ;
. ;DAM 5-01-07 Set up XTMP global where location and patient names are switched
. I '$G(PSGREP) N PSGDEM1 S PSGDEM1=X D ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
. . S PSGREP="PSGM_"_$J
. . S X1=DT,X2=1 D C^%DTC K %,%H,%T
. . S ^XTMP(PSGREP,0)=X_U_DT
. I PSGRBPPN="P",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD and sort by PATIENT
. . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
. . D SPN^PSGMAR0
. I PSGRBPPN="P",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD GROUP and sort by PATIENT
. . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
. . D SPN^PSGMAR0
. S X=$G(PSGDEM1)
. ;END DAM
. ;
. I PSGRBPPN="R",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD and sort by ROOM/BED
. . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. I PSGRBPPN="R",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD GROUP and sort by ROOM/BED
. . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. ;
S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
;
Q
PRT ;*** Print IV orders.
K TS,P,DRG NEW ON55,LN,PSJLABEL S PSJLABEL=1
S ON=$P(DAO,U,2),DFN=$P(PN,U,2) D:ON["V" GT55^PSIVORFB
D:ON["P" GT531^PSIVORFA(DFN,ON)
S TS=1,TMSTR="" I P(9)]"" D ORSET,TS^PSGMAR3(P(11))
F X="LOG",2,3 S:P(X) P(X)=$$ENDTC1^PSGMI(P(X))
S PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I PSGST'="O" S PSGST=$S(P(9)["PRN":"P",1:"C")
S PSGLFFD=PSGPLF
D INITOPI^PSGMMIVC
NEW NAMENEED,NEED,X S NAMENEED=0
D LNNEED,PRTIV
Q
LNNEED ;*** Find lines needed per label.
;*** If OPI<29 char, it is ok to put INITs in the same line.
;*** Add number of lines needed for additives and solutions and 1 line
;*** for infusion rate and x line for OPI. Divide by 5 to determine
;*** of label(s) needed for this order.
F X="AD","SOL" D NAMENEED^PSJMUTL(X,47,.NEED) S NAMENEED=NAMENEED+NEED
S X=($L($P(P("OPI"),"^"))\47)+(($L($P(P("OPI"),"^"))#47)>28)+1+($P(P("OPI"),"^")]""&(P(4)="C"))
S X=(NAMENEED+X+2) S X=$S(X<6:1,1:((X-6)\5)+2)
S LN=$S(TS/6>X:TS/6,1:X)
Q
;
OS ; order record set
Q
;
PRTIV ;*** Print IV order on MAR
D ONHOLD^PSGMMAR2
I PSGMAROC,(PSGMAROC+LN)>6 D BOT^PSGMAR3,HEADER^PSGMAR3
NEW PSGL S PSGL="|"
S PSGMAROC=PSGMAROC+1 W !?6,"|",?19,"|",?48,PSGL,$G(TS(1)),?55,"|"
W !,$E(P("LOG"),1,5)," |"
I ON["V" D
. I $G(ONHOLD) W "O N H O L D" Q
. W $E(P(2),1,5)_$E(P(2),9,14)," |",P(3)
. Q
W:ON["P" "P E N D I N G"
W ?39,"(",$E(PSGP(0))_$E(PSSN,8,12)_")"
W ?48,PSGL,$G(TS(2)),?55,"|" S L=3
NEW NAME,PSIVX
F PSIVX=0:0 S PSIVX=$O(DRG("AD",PSIVX)) Q:'PSIVX D NAME^PSIVUTL(DRG("AD",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y W !,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:(PSIVX=1&((PSGST="O")!(PSGST="C"))) TMSTR^PSGMAR3 D L(1)
W:$G(DRG("SOL",0)) !,"in "
NEW PSJPRT2
F PSIVX=0:0 S PSIVX=$O(DRG("SOL",PSIVX)) Q:'PSIVX D NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y D
. W:(Y>1!(PSIVX>1)) ! W ?4,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)
. S PSJPRT2=$P(^PS(52.7,+DRG("SOL",PSIVX),0),U,4) I PSJPRT2]"" W !?7,PSJPRT2 W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)
W !,$P(P("MR"),U,2)," ",P(9)," ",P(8) W ?48,PSGL,$G(TS(L)),?55,"|" I L>5,(L#5) W !
I '$O(DRG("AD",0))!('$O(DRG("SOL",0))) W !?48,PSGL,$G(TS(L)),?55,"|" S L=5
I P(4)="C",'(L#5),P("OPI")="" W !,"*CAUTION-CHEMOTHERAPY*" S L=L+1 Q
I P(4)="C" D L(1) W !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$G(TS(L)),?55,"|"
;IHS/MSC/PLS - 10/12/2011
I (L#5)=0,($L($P(P("OPI"),"^"))<29),(TS<7) S L=L+1
E D L(1)
;I $L($P(P("OPI"),U)) D L(1) W !
;E S L=L+1
W:P("OPI")=""&(TS>6) !
I P("OPI")'="" D
.; W:(L#6)=1 ! ;IHS/MSC/PLS - 10/12/2011 - Changed to match PSJ*5.0*145
. W:(L#6)=0 !
. F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=$P($P(P("OPI"),"^")," ",Y) D W Y1," "
. I ($X+$L(Y1))>47 W ?48,PSGL,$G(TS(L)),?55,"|" D L(1) W !
I L>TS,(L#6) W ?48,PSGL,$G(TS(L)),?55,"|" S L=L+1 W:L#6=0 !
I (TS-1)>L W ?48,PSGL,$G(TS(L)),?55,"|" D
. F L=L+1:1:TS-1 D L(0) W !?48,PSGL,$G(TS(L)),?55,"|"
. S L=L+1
F Q:'(L#6) W !?48,PSGL,$G(TS(L)),?55,"|" S L=L+1
I '(L#6),(P("OPI")="") W !
I P("OPI")]"",(L>6) W !
W ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2
Q
;
L(X) ;***Check to see if a new block is needed.
S L=L+X
;IHS/MSC/PLS - 10/12/2011
;I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2 S PSGMAROC=PSGMAROC+1,L=L+1 D
I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2,! S PSGMAROC=PSGMAROC+1,L=L+1 D
.I LN>6,(PSGMAROC>5) S MSG1="*** CONTINUE ON NEXT PAGE ***" D BOT^PSGMAR3,HEADER^PSGMAR3 S PSGMAROC=1
Q
ORSET ; order record set
Q:PST["P"!P(9)=""
S PSGMFOR="",(SD,X)=$P(P(2),".") Q:X>PSGPLF S FD=$P(P(3),"."),PSGOES="",X=P(9) D EN^PSGS0 S T=PSGS0XT
S X="" I "OB"]PST,$P(P(9),"^")'["@",P(2)'>PSGPLS,P(3)'<PSGPLF,P(11),T<1441,T'="D" S X=P(11),PSGPLC=1
E I "OB"]PST!(PST["OV") K PSGMAR D SETL0 S (Q,X)="" F QX=0:0 S Q=$O(PSGMAR(Q)) Q:Q="" S X=X_$E("0",2-$L(Q))_Q_"-"
S TMSTR=X
K HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2 Q
Q
SETL0 ;*** Set variable to use in ^PSGPL0 to calculate admin time.
K PSGMAR S PSGPLC=0
S ND1=P(4),ST=P(2),PLSD=P(3),TS=P(11),MN=T,ND=P(9) I $S(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E) S PSGPLC="OI" Q
D ENIV^PSGPL0
Q
;
RPHINIT(RPH) ; Find initial for the person who completed the IV order.
S RPH=$P($G(^PS(55,PSGP,"IV",+ON,4)),U,4)
S:+RPH RPH=$$DEFINIT(+RPH)
I RPH="" S RPH="_____"
Q
DEFINIT(X) ;
S X=$G(^VA(200,X,0)),RPH=$P(X,U,2) Q:RPH]"" RPH
S X=$P(X,U),RPH=$E(X,$F(X,","))_$E(X) Q RPH
PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;03-Apr-2012 10:34;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**4,20,21,28,58,1013,111,131,145,1014**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ; Reference to ^PS(52.7 supported by DBIA #2173.
+5 ; Modified - IHS/MSC/PLS - 10/12/2011 - Line PRTIV+20, L+2
+6 ;
START ;*** Read IV orders
+1 SET ON=""
+2 FOR PSGMARED=PSGPLS-.0001:0
SET PSGMARED=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED))
IF 'PSGMARED
QUIT
FOR
SET ON=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON))
IF ON=""
QUIT
DO IV
+3 QUIT
IV ;*** Sort IV orders for 24 Hrs MAR.
+1 KILL DRG,P
NEW X,ON55,PSJLABEL
SET DFN=PSGP
SET PSJLABEL=1
DO GT55^PSIVORFB
+2 IF P(2)>PSGPLF
QUIT
+3 SET X=$PIECE(P("MR"),U,2)
IF XTYPE=2&(X["IV")
QUIT
IF XTYPE=3&(PST="S")&'($SELECT(X="IV"
QUIT
+4 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
+5 SET QST=$SELECT(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
+6 ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
NEW PSGMARWC
+7 SET PSGMARWC=PSGMARWN
+8 IF $GET(DRG)
SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))
SET X=$EXTRACT($PIECE(X,U,2),1,20)_U_ON_"V"
Begin DoDot:1
+9 NEW A
+10 SET A=$GET(^PS(55,PSGP,"IV",+ON,"DSS"))
IF $PIECE(A,"^")]""
SET PSGMARWN="C!"_$PIECE(A,"^")
IF $GET(SUB1)]""
IF $GET(SUB2)]""
IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
Begin DoDot:2
+11 NEW X,X1,Y
+12 DO SPN^PSGMAR0
+13 QUIT
+14 ;
End DoDot:2
+15 ;DAM 5-01-07 Print by PATIENT
IF PSGSS="P"
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+16 ;DAM 5-01-07 Print by clinic group
IF PSGSS="L"
IF ((PSGINWDG="")&(PSGMARWN'["C!"))
QUIT
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+17 ;DAM 5-01-07 Print by Clinic
IF PSGSS="C"
IF ((PSGINWD="")&(PSGMARWN'["C!"))
QUIT
IF ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!"))
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+18 ;
+19 ;DAM 5-01-07 Set up XTMP global where location and patient names are switched
+20 ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
IF '$GET(PSGREP)
NEW PSGDEM1
SET PSGDEM1=X
Begin DoDot:2
+21 SET PSGREP="PSGM_"_$JOB
+22 SET X1=DT
SET X2=1
DO C^%DTC
KILL %,%H,%T
+23 SET ^XTMP(PSGREP,0)=X_U_DT
End DoDot:2
+24 ;Construct XTMP global for printing by WARD and sort by PATIENT
IF PSGRBPPN="P"
IF PSGSS="W"
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+25 SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""
+26 DO SPN^PSGMAR0
End DoDot:2
+27 ;Construct XTMP global for printing by WARD GROUP and sort by PATIENT
IF PSGRBPPN="P"
IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+28 SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""
+29 DO SPN^PSGMAR0
End DoDot:2
+30 SET X=$GET(PSGDEM1)
+31 ;END DAM
+32 ;
+33 ;Construct TMP global for printing by WARD and sort by ROOM/BED
IF PSGRBPPN="R"
IF PSGSS="W"
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+34 SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
End DoDot:2
+35 ;Construct TMP global for printing by WARD GROUP and sort by ROOM/BED
IF PSGRBPPN="R"
IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+36 SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
End DoDot:2
+37 ;
End DoDot:1
+38 IF PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
+39 ;
+40 QUIT
PRT ;*** Print IV orders.
+1 KILL TS,P,DRG
NEW ON55,LN,PSJLABEL
SET PSJLABEL=1
+2 SET ON=$PIECE(DAO,U,2)
SET DFN=$PIECE(PN,U,2)
IF ON["V"
DO GT55^PSIVORFB
+3 IF ON["P"
DO GT531^PSIVORFA(DFN,ON)
+4 SET TS=1
SET TMSTR=""
IF P(9)]""
DO ORSET
DO TS^PSGMAR3(P(11))
+5 FOR X="LOG",2,3
IF P(X)
SET P(X)=$$ENDTC1^PSGMI(P(X))
+6 SET PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF PSGST'="O"
SET PSGST=$SELECT(P(9)["PRN":"P",1:"C")
+7 SET PSGLFFD=PSGPLF
+8 DO INITOPI^PSGMMIVC
+9 NEW NAMENEED,NEED,X
SET NAMENEED=0
+10 DO LNNEED
DO PRTIV
+11 QUIT
LNNEED ;*** Find lines needed per label.
+1 ;*** If OPI<29 char, it is ok to put INITs in the same line.
+2 ;*** Add number of lines needed for additives and solutions and 1 line
+3 ;*** for infusion rate and x line for OPI. Divide by 5 to determine
+4 ;*** of label(s) needed for this order.
+5 FOR X="AD","SOL"
DO NAMENEED^PSJMUTL(X,47,.NEED)
SET NAMENEED=NAMENEED+NEED
+6 SET X=($LENGTH($PIECE(P("OPI"),"^"))\47)+(($LENGTH($PIECE(P("OPI"),"^"))#47)>28)+1+($PIECE(P("OPI"),"^")]""&(P(4)="C"))
+7 SET X=(NAMENEED+X+2)
SET X=$SELECT(X<6:1,1:((X-6)\5)+2)
+8 SET LN=$SELECT(TS/6>X:TS/6,1:X)
+9 QUIT
+10 ;
OS ; order record set
+1 QUIT
+2 ;
PRTIV ;*** Print IV order on MAR
+1 DO ONHOLD^PSGMMAR2
+2 IF PSGMAROC
IF (PSGMAROC+LN)>6
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
+3 NEW PSGL
SET PSGL="|"
+4 SET PSGMAROC=PSGMAROC+1
WRITE !?6,"|",?19,"|",?48,PSGL,$GET(TS(1)),?55,"|"
+5 WRITE !,$EXTRACT(P("LOG"),1,5)," |"
+6 IF ON["V"
Begin DoDot:1
+7 IF $GET(ONHOLD)
WRITE "O N H O L D"
QUIT
+8 WRITE $EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)," |",P(3)
+9 QUIT
End DoDot:1
+10 IF ON["P"
WRITE "P E N D I N G"
+11 WRITE ?39,"(",$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")"
+12 WRITE ?48,PSGL,$GET(TS(2)),?55,"|"
SET L=3
+13 NEW NAME,PSIVX
+14 FOR PSIVX=0:0
SET PSIVX=$ORDER(DRG("AD",PSIVX))
IF 'PSIVX
QUIT
DO NAME^PSIVUTL(DRG("AD",PSIVX),47,.NAME,1)
FOR Y=0:0
SET Y=$ORDER(NAME(Y))
IF 'Y
QUIT
WRITE !,NAME(Y)
IF L=3
WRITE ?47,PSGST
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
IF (PSIVX=1&((PSGST="O")!(PSGST="C")))
DO TMSTR^PSGMAR3
DO L(1)
+15 IF $GET(DRG("SOL",0))
WRITE !,"in "
+16 NEW PSJPRT2
+17 FOR PSIVX=0:0
SET PSIVX=$ORDER(DRG("SOL",PSIVX))
IF 'PSIVX
QUIT
DO NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1)
FOR Y=0:0
SET Y=$ORDER(NAME(Y))
IF 'Y
QUIT
Begin DoDot:1
+18 IF (Y>1!(PSIVX>1))
WRITE !
WRITE ?4,NAME(Y)
IF L=3
WRITE ?47,PSGST
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
IF L=3
DO TMSTR^PSGMAR3
DO L(1)
+19 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",PSIVX),0),U,4)
IF PSJPRT2]""
WRITE !?7,PSJPRT2
IF L=3
WRITE ?47,PSGST
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
IF L=3
DO TMSTR^PSGMAR3
DO L(1)
End DoDot:1
+20 WRITE !,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
IF L>5
IF (L#5)
WRITE !
+21 IF '$ORDER(DRG("AD",0))!('$ORDER(DRG("SOL",0)))
WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
SET L=5
+22 IF P(4)="C"
IF '(L#5)
IF P("OPI")=""
WRITE !,"*CAUTION-CHEMOTHERAPY*"
SET L=L+1
QUIT
+23 IF P(4)="C"
DO L(1)
WRITE !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$GET(TS(L)),?55,"|"
+24 ;IHS/MSC/PLS - 10/12/2011
+25 IF (L#5)=0
IF ($LENGTH($PIECE(P("OPI"),"^"))<29)
IF (TS<7)
SET L=L+1
+26 IF '$TEST
DO L(1)
+27 ;I $L($P(P("OPI"),U)) D L(1) W !
+28 ;E S L=L+1
+29 IF P("OPI")=""&(TS>6)
WRITE !
+30 IF P("OPI")'=""
Begin DoDot:1
+31 ; W:(L#6)=1 ! ;IHS/MSC/PLS - 10/12/2011 - Changed to match PSJ*5.0*145
+32 IF (L#6)=0
WRITE !
+33 FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
Begin DoDot:2
End DoDot:2
WRITE Y1," "
+34 IF ($X+$LENGTH(Y1))>47
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
DO L(1)
WRITE !
End DoDot:1
+35 IF L>TS
IF (L#6)
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
SET L=L+1
IF L#6=0
WRITE !
+36 IF (TS-1)>L
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
Begin DoDot:1
+37 FOR L=L+1:1:TS-1
DO L(0)
WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
+38 SET L=L+1
End DoDot:1
+39 FOR
IF '(L#6)
QUIT
WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
SET L=L+1
+40 IF '(L#6)
IF (P("OPI")="")
WRITE !
+41 IF P("OPI")]""
IF (L>6)
WRITE !
+42 WRITE ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$GET(TS(L)),?55,"|"
IF PSGMAROC<6
WRITE !?7,LN2
+43 QUIT
+44 ;
L(X) ;***Check to see if a new block is needed.
+1 SET L=L+X
+2 ;IHS/MSC/PLS - 10/12/2011
+3 ;I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2 S PSGMAROC=PSGMAROC+1,L=L+1 D
+4 IF L#6=0
IF PSGMAROC<6
WRITE !,"See next label for continuation",?48,PSGL,$GET(TS(L)),?55,"|"
IF PSGMAROC<6
WRITE !?7,LN2,!
SET PSGMAROC=PSGMAROC+1
SET L=L+1
Begin DoDot:1
+5 IF LN>6
IF (PSGMAROC>5)
SET MSG1="*** CONTINUE ON NEXT PAGE ***"
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
SET PSGMAROC=1
End DoDot:1
+6 QUIT
ORSET ; order record set
+1 IF PST["P"!P(9)=""
QUIT
+2 SET PSGMFOR=""
SET (SD,X)=$PIECE(P(2),".")
IF X>PSGPLF
QUIT
SET FD=$PIECE(P(3),".")
SET PSGOES=""
SET X=P(9)
DO EN^PSGS0
SET T=PSGS0XT
+3 SET X=""
IF "OB"]PST
IF $PIECE(P(9),"^")'["@"
IF P(2)'>PSGPLS
IF P(3)'<PSGPLF
IF P(11)
IF T<1441
IF T'="D"
SET X=P(11)
SET PSGPLC=1
+4 IF '$TEST
IF "OB"]PST!(PST["OV")
KILL PSGMAR
DO SETL0
SET (Q,X)=""
FOR QX=0:0
SET Q=$ORDER(PSGMAR(Q))
IF Q=""
QUIT
SET X=X_$EXTRACT("0",2-$LENGTH(Q))_Q_"-"
+5 SET TMSTR=X
+6 KILL HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2
QUIT
+7 QUIT
SETL0 ;*** Set variable to use in ^PSGPL0 to calculate admin time.
+1 KILL PSGMAR
SET PSGPLC=0
+2 SET ND1=P(4)
SET ST=P(2)
SET PLSD=P(3)
SET TS=P(11)
SET MN=T
SET ND=P(9)
IF $SELECT(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E)
SET PSGPLC="OI"
QUIT
+3 DO ENIV^PSGPL0
+4 QUIT
+5 ;
RPHINIT(RPH) ; Find initial for the person who completed the IV order.
+1 SET RPH=$PIECE($GET(^PS(55,PSGP,"IV",+ON,4)),U,4)
+2 IF +RPH
SET RPH=$$DEFINIT(+RPH)
+3 IF RPH=""
SET RPH="_____"
+4 QUIT
DEFINIT(X) ;
+1 SET X=$GET(^VA(200,X,0))
SET RPH=$PIECE(X,U,2)
IF RPH]""
QUIT RPH
+2 SET X=$PIECE(X,U)
SET RPH=$EXTRACT(X,$FIND(X,","))_$EXTRACT(X)
QUIT RPH
