PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;25 Nov 98 / 9:07 AM
;;5.0;INPATIENT MEDICATIONS;**4,20,21,28,58,111,131,145,267,275**;16 DEC 97;Build 157
;
; Reference to ^PS(55 supported by DBIA #2191.
; Reference to ^PS(52.7 supported by DBIA #2173.
;
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"!(PSGSS="C")!(PSGSS="L") S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q
. S:PSGRBPPN="P" ^TMP($J,TM,PSGMARWN,PPN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. S:PSGRBPPN="R" ^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
N OPILEN,OPILAST S OPILAST=$S(($G(ON55)["V"):$O(^PS(55,DFN,"IV",ON55,10," "),-1),1:"") S OPILEN=$S(OPILAST:(74*OPILAST),1:$L(P("OPI")))
S X=(OPILEN\47)+((OPILEN#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,"|"
I (L#5)=0,($L($P(P("OPI"),"^"))<29),(TS<7) S L=L+1
E D L(1)
W:P("OPI")=""&(TS>6) !
I P("OPI")'="" I '$$OPI(PSGP,ON55) D
. W:(L#6)=1 !
. 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
;
OPI(DFN,ORDER,OPITEXT,OPIPRINT) ; Retrieve, format, and print Other Print Info
N TXTLN S TXTLN=$$GETSIOPI^PSJBCMA5($G(DFN),$G(ORDER),1) I 'TXTLN Q 0
N TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II,Y K MARX S LAST=0,TMPMARX="" S PSGL=$S(($G(PSGL)]""):PSGL,1:"|")
I ORDER["V" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(55,DFN,"IV",+ORDER,10,TXTLN)) Q:'TXTLN D
.S MARXTXT=^PS(55,DFN,"IV",+ORDER,10,TXTLN,0) D TXT^PSGMUTL(MARXTXT,47) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
I ORDER["P" S TXTLN=0 F I=1:1 S TXTLN=$O(^PS(53.1,+ORDER,16,TXTLN)) Q:'TXTLN D
.S MARXTXT=^PS(53.1,+ORDER,16,TXTLN,0) D TXT^PSGMUTL(MARXTXT,47) S LAST=$O(TMPMARX(" "),-1) S II=0 F S II=$O(MARX(II)) Q:'II S TMPMARX(LAST+II)=MARX(II)
I $G(OPIPRINT) K MARX M MARX=TMPMARX S I=0 F S I=$O(MARX(I)) Q:'I D
. W:(L#6)=0 !
. S Y1=MARX(I) W Y1," ",?48,PSGL,$G(TS(L)),?55,"|" D L(1) W !
I $G(OPITEXT) M OPITEXT=TMPMARX
Q 1
L(X) ;***Check to see if a new block is needed.
S L=L+X
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMIV 7069 printed Oct 16, 2024@18:02:19 Page 2
PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;25 Nov 98 / 9:07 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**4,20,21,28,58,111,131,145,267,275**;16 DEC 97;Build 157
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ; Reference to ^PS(52.7 supported by DBIA #2173.
+5 ;
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
End DoDot:2
+14 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+15 if PSGRBPPN="P"
SET ^TMP($JOB,TM,PSGMARWN,PPN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
+16 if PSGRBPPN="R"
SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
End DoDot:1
+17 if PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
+18 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 NEW OPILEN,OPILAST
SET OPILAST=$SELECT(($GET(ON55)["V"):$ORDER(^PS(55,DFN,"IV",ON55,10," "),-1),1:"")
SET OPILEN=$SELECT(OPILAST:(74*OPILAST),1:$LENGTH(P("OPI")))
+7 SET X=(OPILEN\47)+((OPILEN#47)>28)+1+($PIECE(P("OPI"),"^")]""&(P(4)="C"))
+8 SET X=(NAMENEED+X+2)
SET X=$SELECT(X<6:1,1:((X-6)\5)+2)
+9 SET LN=$SELECT(TS/6>X:TS/6,1:X)
+10 QUIT
+11 ;
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 IF (L#5)=0
IF ($LENGTH($PIECE(P("OPI"),"^"))<29)
IF (TS<7)
SET L=L+1
+25 IF '$TEST
DO L(1)
+26 if P("OPI")=""&(TS>6)
WRITE !
+27 IF P("OPI")'=""
IF '$$OPI(PSGP,ON55)
Begin DoDot:1
+28 if (L#6)=1
WRITE !
+29 FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)
Begin DoDot:2
End DoDot:2
WRITE Y1," "
+30 IF ($X+$LENGTH(Y1))>47
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
DO L(1)
WRITE !
End DoDot:1
+31 IF L>TS
IF (L#6)
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
SET L=L+1
if L#6=0
WRITE !
+32 IF (TS-1)>L
WRITE ?48,PSGL,$GET(TS(L)),?55,"|"
Begin DoDot:1
+33 FOR L=L+1:1:TS-1
DO L(0)
WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
+34 SET L=L+1
End DoDot:1
+35 FOR
if '(L#6)
QUIT
WRITE !?48,PSGL,$GET(TS(L)),?55,"|"
SET L=L+1
+36 IF '(L#6)
IF (P("OPI")="")
WRITE !
+37 IF P("OPI")]""
IF (L>6)
WRITE !
+38 WRITE ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$GET(TS(L)),?55,"|"
if PSGMAROC<6
WRITE !?7,LN2
+39 QUIT
+40 ;
OPI(DFN,ORDER,OPITEXT,OPIPRINT) ; Retrieve, format, and print Other Print Info
+1 NEW TXTLN
SET TXTLN=$$GETSIOPI^PSJBCMA5($GET(DFN),$GET(ORDER),1)
IF 'TXTLN
QUIT 0
+2 NEW TXTLN,TXT,I,TMPMARX,MARXTXT,LAST,II,Y
KILL MARX
SET LAST=0
SET TMPMARX=""
SET PSGL=$SELECT(($GET(PSGL)]""):PSGL,1:"|")
+3 IF ORDER["V"
SET TXTLN=0
FOR I=1:1
SET TXTLN=$ORDER(^PS(55,DFN,"IV",+ORDER,10,TXTLN))
if 'TXTLN
QUIT
Begin DoDot:1
+4 SET MARXTXT=^PS(55,DFN,"IV",+ORDER,10,TXTLN,0)
DO TXT^PSGMUTL(MARXTXT,47)
SET LAST=$ORDER(TMPMARX(" "),-1)
SET II=0
FOR
SET II=$ORDER(MARX(II))
if 'II
QUIT
SET TMPMARX(LAST+II)=MARX(II)
End DoDot:1
+5 IF ORDER["P"
SET TXTLN=0
FOR I=1:1
SET TXTLN=$ORDER(^PS(53.1,+ORDER,16,TXTLN))
if 'TXTLN
QUIT
Begin DoDot:1
+6 SET MARXTXT=^PS(53.1,+ORDER,16,TXTLN,0)
DO TXT^PSGMUTL(MARXTXT,47)
SET LAST=$ORDER(TMPMARX(" "),-1)
SET II=0
FOR
SET II=$ORDER(MARX(II))
if 'II
QUIT
SET TMPMARX(LAST+II)=MARX(II)
End DoDot:1
+7 IF $GET(OPIPRINT)
KILL MARX
MERGE MARX=TMPMARX
SET I=0
FOR
SET I=$ORDER(MARX(I))
if 'I
QUIT
Begin DoDot:1
+8 if (L#6)=0
WRITE !
+9 SET Y1=MARX(I)
WRITE Y1," ",?48,PSGL,$GET(TS(L)),?55,"|"
DO L(1)
WRITE !
End DoDot:1
+10 IF $GET(OPITEXT)
MERGE OPITEXT=TMPMARX
+11 QUIT 1
L(X) ;***Check to see if a new block is needed.
+1 SET L=L+X
+2 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
+3 IF LN>6
IF (PSGMAROC>5)
SET MSG1="*** CONTINUE ON NEXT PAGE ***"
DO BOT^PSGMAR3
DO HEADER^PSGMAR3
SET PSGMAROC=1
End DoDot:1
+4 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
