PSIVPRO ;BIR/PR,MLM - PROFILE AN ORDER ;Jul 03, 2018@08:39
;;5.0;INPATIENT MEDICATIONS;**38,58,85,110,181,263,275,373**;16 DEC 97;Build 3
;33
; Reference to ^PS(55 is supported by DBIA 2191
;
;Needs DFN and ^TMP("PSIV",$J) array
N PSJCLNSV
S PSJLN=1,PSIVX2=0
S PSIVST=$O(^TMP("PSIV",$J,0)),X="",(PSIVON,PS)=0 D REACT I PSIVST]"" F PSIVX1=1:1 D PSIVST Q:'PSIVON D PR
S ^TMP("PSJPRO",$J,0)=PSIVX2,VALMCNT=PSJLN-1
I $G(PSIVBR)="D ^PSIVOPT" S VALM("TITLE")="IV Order Entry"
E S VALM("TITLE")="IV Profile"
QUIT ; Kill and exit.
S ON=X K ADM,AL,DRG,GMRA,GMRAL,PSIVST,PSIVX1,PSIVX2,Y,NAD,N0,X3,X4,X5
Q
;
PSIVST ;
S PSIVON=$O(^TMP("PSIV",$J,PSIVST,PSIVON)) I 'PSIVON S PSIVST=$O(^TMP("PSIV",$J,PSIVST_"Z")) I PSIVST]"" S PSIVON=$O(^TMP("PSIV",$J,PSIVST,0)) D HDL
Q
REACT ;
S PSJL="# Additive",PSJL=$$SETSTR^VALM1("Last fill",PSJL,32,9)
;S PSJL=$$SETSTR^VALM1("Type",PSJL,49,4),PSJL=$$SETSTR^VALM1(" Start Stop Stat",PSJL,54,19) ;#373
S PSJL=$$SETSTR^VALM1("Type",PSJL,49,4),PSJL=$$SETSTR^VALM1(" Start Stop Stat",PSJL,54,26) ;#373
;S PSJL=$$SETSTR^VALM1("Renew",PSJL,74,5) ;#373
D SETTMP^PSJLMPRI
HDL ; Display type heading.
S PSJL=""
D ACL:($P(PSIVST,"^")'="Cz")&(PSIVST="A"),DPL:($P(PSIVST,"^")'="Cz")&(PSIVST="RD"),POL:($P(PSIVST,"^")'="Cz")&(PSIVST="P"),POCL:($P(PSIVST,"^")'="Cz")&(PSIVST="PD")
D NVL:($P(PSIVST,"^")'="Cz")&(PSIVST="N"),NVCL:($P(PSIVST,"^")'="Cz")&(PSIVST="ND"),NOL:($P(PSIVST,"^")'="Cz")&(PSIVST="X")
D NOC:($P(PSIVST,"^")'="Cz")&(PSIVST=""),CLIN($P(PSIVST,"^",2)):($P(PSIVST,"^")="Cz"&($P(PSIVST,"^",2)'=$G(PSJCLNSV))) S X=""
I ($P(PSIVST,"^")="Cz") S PSJCLNSV=$P(PSIVST,"^",2)
S PSJL=$E(PSJL,1,79) D SETTMP^PSJLMPRI
Q
;
PR ; Get & display order.
I ($P(PSIVST,"^")'="Cz") S (ON,ON55)=9999999999-($S(PSIVST["P":$E(PSIVON,2,11),PSIVST["N":$E(PSIVON,2,11),1:PSIVON))_$S(PSIVST["P":"P",PSIVST["N":"P",1:"V") D
.D @$S(PSIVST["P":"GT531^PSIVORFA(DFN,ON)",PSIVST["N":"GT531^PSIVORFA(DFN,ON)",1:"GT55^PSIVORFB")
I ($P(PSIVST,"^")="Cz") S (ON,ON55)=9999999999-($S($P(PSIVST,"^",4)["P":$E(PSIVON,2,11),$P(PSIVST,"^",4)["N":$E(PSIVON,2,11),1:PSIVON))_$S($P(PSIVST,"^",4)["P":"P",$P(PSIVST,"^",4)["N":"P",1:"V") D
.D @$S($P(PSIVST,"^",4)["P":"GT531^PSIVORFA(DFN,ON)",$P(PSIVST,"^",4)["N":"GT531^PSIVORFA(DFN,ON)",1:"GT55^PSIVORFB")
S X="",PS=PSIVX1 K ^TMP("PSIV",$J,PSIVST,PSIVON) D
.I ($P(PSIVST,"^")'="Cz") S ^TMP("PSIV",$J,PSIVST_"B",PSIVX1)=$S(PSIVST["P":$E(PSIVON,2,11),PSIVST["N":$E(PSIVON,2,11),1:PSIVON)_$S(PSIVST["P":"P",PSIVST["N":"P",1:"V")
.I ($P(PSIVST,"^")="Cz") S ^TMP("PSIV",$J,PSIVST_"B",PSIVX1)=$S($P(PSIVST,"^",4)["P":$E(PSIVON,2,11),$P(PSIVST,"^",4)["N":$E(PSIVON,2,11),1:PSIVON)_$S($P(PSIVST,"^",4)["P":"P",$P(PSIVST,"^",4)["N":"P",1:"V")
.I PSIVST="RD"!($P(PSIVST,"^",4)="RD") D ENPL Q
I ($P(PSIVST,"^")'="Cz"),(PSIVST["D") N PSJO,PSIVX3 S PSIVX3=PSIVX1,PSJO=0 I $G(PSJCOM) D
.F S PSJO=$O(^PS(53.1,"ACX",PSJCOM,PSJO)) Q:'PSJO S ON=PSJO_"P" D GT531^PSIVORFA(DFN,ON),ENPL S PSIVX1=""
I ($P(PSIVST,"^")'="Cz"),(PSIVST["D") S PSIVX1=PSIVX3 Q
;
ENPL ;
NEW MARX,DRUGNAME,X,XX
S PSJL=$J(PSIVX1,4) I ON["P",(P("OT")'="F"),P(4)'="H" D Q
. I $D(VALMEVL) D
.. N PSJFLAG
.. S PSJFLAG=$P($S(ON["V":$G(^PS(55,DFN,"IV",+ON,.2)),1:$G(^PS(53.1,+ON,.2))),U,7)
.. I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
. D DRGDISP^PSJLMUT1(DFN,ON,34,59,.DRUGNAME,0)
. NEW X F X=0:0 S X=$O(DRUGNAME(X)) Q:'X S:X>1 PSJL="" S PSJL=$$SETSTR^VALM1(DRUGNAME(X),PSJL,$S(X=1:6,1:7),$S(X=1:34,1:65)) D:X=1 V D SETTMP^PSJLMPRI
S X=$J(PSIVX1,4)_$S(P("PRY")="D":" d",1:" ")
I ON["V" S XX=$G(^PS(55,DFN,"IV",+ON,4)) D
. I +PSJSYSU=1,'+XX S X=X_"->"
. I +PSJSYSU=3,'+$P(XX,U,4) S X=X_"->"
S PSJL=X
I $D(VALMEVL) D
. N PSJFLAG
. S PSJFLAG=$P($S(ON["V":$G(^PS(55,DFN,"IV",+ON,.2)),1:$G(^PS(53.1,+ON,.2))),U,7)
. I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
NEW RNWPRTD S RNWPRTD=0 ;#373
D AD,SOL
I 'RNWPRTD D RENEWDT I PSJL["Renewed" D SETTMP^PSJLMPRI ;#373
Q
SOL ;
NEW NAME,PSJNOAD,L ;S PSJNOAD=0,L=34
S NAD=0 F S NAD=$O(DRG("SOL",NAD)) Q:'NAD D
. K NAME S L=34,PSJNOAD=0
. I '$D(DRG("AD",1)),NAD=1 S PSJNOAD=1,L=27
. S:NAD=1 PSJL=$$SETSTR^VALM1("in",PSJL,6,11)
. D NAME^PSIVUTL(DRG("SOL",NAD),L,.NAME,0)
. F X=0:0 S X=$O(NAME(X)) Q:'X S:(NAD>1!(X>1)) PSJL="" S PSJL=$$SETSTR^VALM1(NAME(X),PSJL,9,34) D:X=1&PSJNOAD V D:(NAD>1!(X>1)) RENEWDT D SETTMP^PSJLMPRI ;#373 - Call to RENEWDT added
. S PSJL=""
Q
AD ;
NEW NAME
S NAD=0 F S NAD=$O(DRG("AD",NAD)) Q:'NAD D
. K NAME
. ;D NAME^PSIVUTL(DRG("AD",NAD),30,.NAME,1)
. D NAME^PSIVUTL(DRG("AD",NAD),27,.NAME,1)
. F X=0:0 S X=$O(NAME(X)) Q:'X S:(NAD>1!(X>1)) PSJL="" S PSJL=$$SETSTR^VALM1(NAME(X),PSJL,6,34) D:(NAD=1&(X=1)) V D:(NAD>1!(X>1)) RENEWDT D SETTMP^PSJLMPRI ;#373 - Call to RENEWDT added
. S PSJL=""
Q
;
V S Y=$S(ON["V":$P($G(^PS(55,DFN,"IV",+ON,9)),U),1:"")
I +Y>0 X ^DD("DD") S Y=$P(Y,",")_" "_$P($P(Y,"@",2),":",1,2)
E S Y="** N/P **"
S PSJL=$$SETSTR^VALM1(Y,PSJL,33,12)
S PSJL=$$SETSTR^VALM1(" #"_$S(ON["V":+$P($G(^PS(55,DFN,"IV",+ON,9)),U,2),1:0),PSJL,46,3)
S:PSIVX1]"" PSIVX2=PSIVX2+1
D REST
Q
ACL ;
F X3=1:1:71 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" A c t i v e "
Q
NVL ;
F X3=1:1:71 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" N o n - V e r i f i e d "
Q
NVCL ;
F X3=1:1:71 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" N o n - V e r i f i e d C o m p l e x "
Q
POL ;
F X3=1:1:71 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" P e n d i n g "
Q
POCL ;
F X3=1:1:66 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" P e n d i n g C o m p l e x "
Q
NOL ;
F X3=1:1:66 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" N o t A c t i v e "
Q
CLIN(CLINIC) ; Print Clinic Name section header
N LEFTALIN S LEFTALIN=(80-$L(CLINIC))\2
F X3=1:1:71 S PSJL=PSJL_"-" S:(X3=(LEFTALIN)) PSJL=PSJL_CLINIC
Q
DPL ;Recently dc/expired header
S PSJDCEXP=$$RECDCEXP^PSJP()
F X3=1:1:71 S PSJL=PSJL_"-" S:X3=15 PSJL=PSJL_"Recently Discontinued/Expired (Last "_+$G(PSJDCEXP)_" hours)"
Q
NOC ;
F X3=1:1:66 S PSJL=PSJL_"-" S:X3=34 PSJL=PSJL_" No current IV information "
;
S PSJL=""
Q
REST ;
S PSJL=$$SETSTR^VALM1(P(4),PSJL,52,1)
;S PSJL=$$SETSTR^VALM1($E($$ENDTC^PSGMI(P(2)),1,5),PSJL,55,5) ;#373
S PSJL=$$SETSTR^VALM1($E($$ENDTC2^PSGMI(P(2)),1,10),PSJL,55,10) ;#373
;S PSJL=$$SETSTR^VALM1($E($$ENDTC^PSGMI(P(3)),1,5),PSJL,62,5) ;#373
S PSJL=$$SETSTR^VALM1($E($$ENDTC2^PSGMI(P(3)),1,10),PSJL,66,10) ;#373
;S PSJL=$$SETSTR^VALM1($S(P(17)="R"&(ON'["V"):"R/I",$G(P(25))]"":P(25),1:P(17)),PSJL,69,2) ;#373
S PSJL=$$SETSTR^VALM1($S(P(17)="R"&(ON'["V"):"R/I",$G(P(25))]"":P(25),1:P(17)),PSJL,77,2) ;#373
;S PSJL=$$SETSTR^VALM1($S(ON["P":P("PRY"),1:""),PSJL,71,1) ;#373
S PSJL=$$SETSTR^VALM1($S(ON["P":P("PRY"),1:""),PSJL,79,1) ;#373
;N PSJLRN S PSJLRN=$$LASTREN^PSJLMPRI(DFN,ON55) I PSJLRN S PSJLRN=$E($$ENDTC^PSGMI(PSJLRN),1,5) S PSJL=$$SETSTR^VALM1(PSJLRN,PSJL,74,5) ;#373
Q
RENEWDT ; 373 - Put renewal date on 2nd line instead of 1st.
Q:RNWPRTD
N PSJLRN S PSJLRN=$$LASTREN^PSJLMPRI(DFN,ON55)
I PSJLRN D
. S PSJLRN=$E($$ENDTC2^PSGMI(PSJLRN),1,10)
. S PSJL=$$SETSTR^VALM1("Renewed:",PSJL,55,8)
. S PSJL=$$SETSTR^VALM1(PSJLRN,PSJL,64,10),RNWPRTD=1
Q
XCHK ;
I $E(X)="?" W !!?2,"Select order",$E("s",PS'=1)," (1" W:PS>1 "-",PS W ")."
I $E(X)="?" W:$S($O(^TMP("PSIV",$J,PSIVST,ON)):1,1:$O(^TMP("PSIV",$J,PSIVST))]"") " Press RETURN to view more orders, or enter '^' to abort",!,"the profile, or 'A' to view Allergies." D:$E(X,1,2)="??" H2^PSGON K X Q
S PSGLMT=PS D ^PSGON Q
;
PSPD S Y=$S(PSIVST'="P":$P($G(^PS(55,DFN,"IV",+ON,9)),U),1:"")
X ^DD("DD") S:Y="" PSJL=$$SETSTR^VALM1("** N/P **",PSJL,36,12)
S:Y'="" PSJL=$$SETSTR^VALM1($P(Y,","),PSJL,36,7),PSJL=$$SETSTR^VALM1($P($P(Y,"@",2),":",1,2),PSJL,43,45)
S PSJL=PSJL_" #"_$S(Y="":0,1:$P(^PS(55,DFN,"IV",+ON,9),U,2))
D REST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVPRO 7882 printed Dec 13, 2024@02:04:53 Page 2
PSIVPRO ;BIR/PR,MLM - PROFILE AN ORDER ;Jul 03, 2018@08:39
+1 ;;5.0;INPATIENT MEDICATIONS;**38,58,85,110,181,263,275,373**;16 DEC 97;Build 3
+2 ;33
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ;
+5 ;Needs DFN and ^TMP("PSIV",$J) array
+6 NEW PSJCLNSV
+7 SET PSJLN=1
SET PSIVX2=0
+8 SET PSIVST=$ORDER(^TMP("PSIV",$JOB,0))
SET X=""
SET (PSIVON,PS)=0
DO REACT
IF PSIVST]""
FOR PSIVX1=1:1
DO PSIVST
if 'PSIVON
QUIT
DO PR
+9 SET ^TMP("PSJPRO",$JOB,0)=PSIVX2
SET VALMCNT=PSJLN-1
+10 IF $GET(PSIVBR)="D ^PSIVOPT"
SET VALM("TITLE")="IV Order Entry"
+11 IF '$TEST
SET VALM("TITLE")="IV Profile"
QUIT ; Kill and exit.
+1 SET ON=X
KILL ADM,AL,DRG,GMRA,GMRAL,PSIVST,PSIVX1,PSIVX2,Y,NAD,N0,X3,X4,X5
+2 QUIT
+3 ;
PSIVST ;
+1 SET PSIVON=$ORDER(^TMP("PSIV",$JOB,PSIVST,PSIVON))
IF 'PSIVON
SET PSIVST=$ORDER(^TMP("PSIV",$JOB,PSIVST_"Z"))
IF PSIVST]""
SET PSIVON=$ORDER(^TMP("PSIV",$JOB,PSIVST,0))
DO HDL
+2 QUIT
REACT ;
+1 SET PSJL="# Additive"
SET PSJL=$$SETSTR^VALM1("Last fill",PSJL,32,9)
+2 ;S PSJL=$$SETSTR^VALM1("Type",PSJL,49,4),PSJL=$$SETSTR^VALM1(" Start Stop Stat",PSJL,54,19) ;#373
+3 ;#373
SET PSJL=$$SETSTR^VALM1("Type",PSJL,49,4)
SET PSJL=$$SETSTR^VALM1(" Start Stop Stat",PSJL,54,26)
+4 ;S PSJL=$$SETSTR^VALM1("Renew",PSJL,74,5) ;#373
+5 DO SETTMP^PSJLMPRI
HDL ; Display type heading.
+1 SET PSJL=""
+2 if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="A")
DO ACL
if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="RD")
DO DPL
if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="P")
DO POL
if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="PD")
DO POCL
+3 if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="N")
DO NVL
if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="ND")
DO NVCL
if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="X")
DO NOL
+4 if ($PIECE(PSIVST,"^")'="Cz")&(PSIVST="")
DO NOC
if ($PIECE(PSIVST,"^")="Cz"&($PIECE(PSIVST,"^",2)'=$GET(PSJCLNSV)))
DO CLIN($PIECE(PSIVST,"^",2))
SET X=""
+5 IF ($PIECE(PSIVST,"^")="Cz")
SET PSJCLNSV=$PIECE(PSIVST,"^",2)
+6 SET PSJL=$EXTRACT(PSJL,1,79)
DO SETTMP^PSJLMPRI
+7 QUIT
+8 ;
PR ; Get & display order.
+1 IF ($PIECE(PSIVST,"^")'="Cz")
SET (ON,ON55)=9999999999-($SELECT(PSIVST["P":$EXTRACT(PSIVON,2,11),PSIVST["N":$EXTRACT(PSIVON,2,11),1:PSIVON))_$SELECT(PSIVST["P":"P",PSIVST["N":"P",1:"V")
Begin DoDot:1
+2 DO @$SELECT(PSIVST["P":"GT531^PSIVORFA(DFN,ON)",PSIVST["N":"GT531^PSIVORFA(DFN,ON)",1:"GT55^PSIVORFB")
End DoDot:1
+3 IF ($PIECE(PSIVST,"^")="Cz")
SET (ON,ON55)=9999999999-($SELECT($PIECE(PSIVST,"^",4)["P":$EXTRACT(PSIVON,2,11),$PIECE(PSIVST,"^",4)["N":$EXTRACT(PSIVON,2,11),1:PSIVON))_$SELECT($PIECE(PSIVST,"^",4)["P":"P",$PIECE(PSIVST,"^",4)["N":"P",1:"V")
Begin DoDot:1
+4 DO @$SELECT($PIECE(PSIVST,"^",4)["P":"GT531^PSIVORFA(DFN,ON)",$PIECE(PSIVST,"^",4)["N":"GT531^PSIVORFA(DFN,ON)",1:"GT55^PSIVORFB")
End DoDot:1
+5 SET X=""
SET PS=PSIVX1
KILL ^TMP("PSIV",$JOB,PSIVST,PSIVON)
Begin DoDot:1
+6 IF ($PIECE(PSIVST,"^")'="Cz")
SET ^TMP("PSIV",$JOB,PSIVST_"B",PSIVX1)=$SELECT(PSIVST["P":$EXTRACT(PSIVON,2,11),PSIVST["N":$EXTRACT(PSIVON,2,11),1:PSIVON)_$SELECT(PSIVST["P":"P",PSIVST["N":"P",1:"V")
+7 IF ($PIECE(PSIVST,"^")="Cz")
SET ^TMP("PSIV",$JOB,PSIVST_"B",PSIVX1)=$SELECT($PIECE(PSIVST,"^",4)["P":$EXTRACT(PSIVON,2,11),$PIECE(PSIVST,"^",4)["N":$EXTRACT(PSIVON,2,11),1:PSIVON)_$SELECT($PIECE(PSIVST,"^",4)["P":"P",$PIECE(PSIVST,"^",4)["N":"P",1:"V")
+8 IF PSIVST="RD"!($PIECE(PSIVST,"^",4)="RD")
DO ENPL
QUIT
End DoDot:1
+9 IF ($PIECE(PSIVST,"^")'="Cz")
IF (PSIVST["D")
NEW PSJO,PSIVX3
SET PSIVX3=PSIVX1
SET PSJO=0
IF $GET(PSJCOM)
Begin DoDot:1
+10 FOR
SET PSJO=$ORDER(^PS(53.1,"ACX",PSJCOM,PSJO))
if 'PSJO
QUIT
SET ON=PSJO_"P"
DO GT531^PSIVORFA(DFN,ON)
DO ENPL
SET PSIVX1=""
End DoDot:1
+11 IF ($PIECE(PSIVST,"^")'="Cz")
IF (PSIVST["D")
SET PSIVX1=PSIVX3
QUIT
+12 ;
ENPL ;
+1 NEW MARX,DRUGNAME,X,XX
+2 SET PSJL=$JUSTIFY(PSIVX1,4)
IF ON["P"
IF (P("OT")'="F")
IF P(4)'="H"
Begin DoDot:1
+3 IF $DATA(VALMEVL)
Begin DoDot:2
+4 NEW PSJFLAG
+5 SET PSJFLAG=$PIECE($SELECT(ON["V":$GET(^PS(55,DFN,"IV",+ON,.2)),1:$GET(^PS(53.1,+ON,.2))),U,7)
+6 IF PSJFLAG
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
End DoDot:2
+7 DO DRGDISP^PSJLMUT1(DFN,ON,34,59,.DRUGNAME,0)
+8 NEW X
FOR X=0:0
SET X=$ORDER(DRUGNAME(X))
if 'X
QUIT
if X>1
SET PSJL=""
SET PSJL=$$SETSTR^VALM1(DRUGNAME(X),PSJL,$SELECT(X=1:6,1:7),$SELECT(X=1:34,1:65))
if X=1
DO V
DO SETTMP^PSJLMPRI
End DoDot:1
QUIT
+9 SET X=$JUSTIFY(PSIVX1,4)_$SELECT(P("PRY")="D":" d",1:" ")
+10 IF ON["V"
SET XX=$GET(^PS(55,DFN,"IV",+ON,4))
Begin DoDot:1
+11 IF +PSJSYSU=1
IF '+XX
SET X=X_"->"
+12 IF +PSJSYSU=3
IF '+$PIECE(XX,U,4)
SET X=X_"->"
End DoDot:1
+13 SET PSJL=X
+14 IF $DATA(VALMEVL)
Begin DoDot:1
+15 NEW PSJFLAG
+16 SET PSJFLAG=$PIECE($SELECT(ON["V":$GET(^PS(55,DFN,"IV",+ON,.2)),1:$GET(^PS(53.1,+ON,.2))),U,7)
+17 IF PSJFLAG
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
End DoDot:1
+18 ;#373
NEW RNWPRTD
SET RNWPRTD=0
+19 DO AD
DO SOL
+20 ;#373
IF 'RNWPRTD
DO RENEWDT
IF PSJL["Renewed"
DO SETTMP^PSJLMPRI
+21 QUIT
SOL ;
+1 ;S PSJNOAD=0,L=34
NEW NAME,PSJNOAD,L
+2 SET NAD=0
FOR
SET NAD=$ORDER(DRG("SOL",NAD))
if 'NAD
QUIT
Begin DoDot:1
+3 KILL NAME
SET L=34
SET PSJNOAD=0
+4 IF '$DATA(DRG("AD",1))
IF NAD=1
SET PSJNOAD=1
SET L=27
+5 if NAD=1
SET PSJL=$$SETSTR^VALM1("in",PSJL,6,11)
+6 DO NAME^PSIVUTL(DRG("SOL",NAD),L,.NAME,0)
+7 ;#373 - Call to RENEWDT added
FOR X=0:0
SET X=$ORDER(NAME(X))
if 'X
QUIT
if (NAD>1!(X>1))
SET PSJL=""
SET PSJL=$$SETSTR^VALM1(NAME(X),PSJL,9,34)
if X=1&PSJNOAD
DO V
if (NAD>1!(X>1))
DO RENEWDT
DO SETTMP^PSJLMPRI
+8 SET PSJL=""
End DoDot:1
+9 QUIT
AD ;
+1 NEW NAME
+2 SET NAD=0
FOR
SET NAD=$ORDER(DRG("AD",NAD))
if 'NAD
QUIT
Begin DoDot:1
+3 KILL NAME
+4 ;D NAME^PSIVUTL(DRG("AD",NAD),30,.NAME,1)
+5 DO NAME^PSIVUTL(DRG("AD",NAD),27,.NAME,1)
+6 ;#373 - Call to RENEWDT added
FOR X=0:0
SET X=$ORDER(NAME(X))
if 'X
QUIT
if (NAD>1!(X>1))
SET PSJL=""
SET PSJL=$$SETSTR^VALM1(NAME(X),PSJL,6,34)
if (NAD=1&(X=1))
DO V
if (NAD>1!(X>1))
DO RENEWDT
DO SETTMP^PSJLMPRI
+7 SET PSJL=""
End DoDot:1
+8 QUIT
+9 ;
V SET Y=$SELECT(ON["V":$PIECE($GET(^PS(55,DFN,"IV",+ON,9)),U),1:"")
+1 IF +Y>0
XECUTE ^DD("DD")
SET Y=$PIECE(Y,",")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+2 IF '$TEST
SET Y="** N/P **"
+3 SET PSJL=$$SETSTR^VALM1(Y,PSJL,33,12)
+4 SET PSJL=$$SETSTR^VALM1(" #"_$SELECT(ON["V":+$PIECE($GET(^PS(55,DFN,"IV",+ON,9)),U,2),1:0),PSJL,46,3)
+5 if PSIVX1]""
SET PSIVX2=PSIVX2+1
+6 DO REST
+7 QUIT
ACL ;
+1 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" A c t i v e "
+2 QUIT
NVL ;
+1 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" N o n - V e r i f i e d "
+2 QUIT
NVCL ;
+1 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" N o n - V e r i f i e d C o m p l e x "
+2 QUIT
POL ;
+1 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" P e n d i n g "
+2 QUIT
POCL ;
+1 FOR X3=1:1:66
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" P e n d i n g C o m p l e x "
+2 QUIT
NOL ;
+1 FOR X3=1:1:66
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" N o t A c t i v e "
+2 QUIT
CLIN(CLINIC) ; Print Clinic Name section header
+1 NEW LEFTALIN
SET LEFTALIN=(80-$LENGTH(CLINIC))\2
+2 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if (X3=(LEFTALIN))
SET PSJL=PSJL_CLINIC
+3 QUIT
DPL ;Recently dc/expired header
+1 SET PSJDCEXP=$$RECDCEXP^PSJP()
+2 FOR X3=1:1:71
SET PSJL=PSJL_"-"
if X3=15
SET PSJL=PSJL_"Recently Discontinued/Expired (Last "_+$GET(PSJDCEXP)_" hours)"
+3 QUIT
NOC ;
+1 FOR X3=1:1:66
SET PSJL=PSJL_"-"
if X3=34
SET PSJL=PSJL_" No current IV information "
+2 ;
+3 SET PSJL=""
+4 QUIT
REST ;
+1 SET PSJL=$$SETSTR^VALM1(P(4),PSJL,52,1)
+2 ;S PSJL=$$SETSTR^VALM1($E($$ENDTC^PSGMI(P(2)),1,5),PSJL,55,5) ;#373
+3 ;#373
SET PSJL=$$SETSTR^VALM1($EXTRACT($$ENDTC2^PSGMI(P(2)),1,10),PSJL,55,10)
+4 ;S PSJL=$$SETSTR^VALM1($E($$ENDTC^PSGMI(P(3)),1,5),PSJL,62,5) ;#373
+5 ;#373
SET PSJL=$$SETSTR^VALM1($EXTRACT($$ENDTC2^PSGMI(P(3)),1,10),PSJL,66,10)
+6 ;S PSJL=$$SETSTR^VALM1($S(P(17)="R"&(ON'["V"):"R/I",$G(P(25))]"":P(25),1:P(17)),PSJL,69,2) ;#373
+7 ;#373
SET PSJL=$$SETSTR^VALM1($SELECT(P(17)="R"&(ON'["V"):"R/I",$GET(P(25))]"":P(25),1:P(17)),PSJL,77,2)
+8 ;S PSJL=$$SETSTR^VALM1($S(ON["P":P("PRY"),1:""),PSJL,71,1) ;#373
+9 ;#373
SET PSJL=$$SETSTR^VALM1($SELECT(ON["P":P("PRY"),1:""),PSJL,79,1)
+10 ;N PSJLRN S PSJLRN=$$LASTREN^PSJLMPRI(DFN,ON55) I PSJLRN S PSJLRN=$E($$ENDTC^PSGMI(PSJLRN),1,5) S PSJL=$$SETSTR^VALM1(PSJLRN,PSJL,74,5) ;#373
+11 QUIT
RENEWDT ; 373 - Put renewal date on 2nd line instead of 1st.
+1 if RNWPRTD
QUIT
+2 NEW PSJLRN
SET PSJLRN=$$LASTREN^PSJLMPRI(DFN,ON55)
+3 IF PSJLRN
Begin DoDot:1
+4 SET PSJLRN=$EXTRACT($$ENDTC2^PSGMI(PSJLRN),1,10)
+5 SET PSJL=$$SETSTR^VALM1("Renewed:",PSJL,55,8)
+6 SET PSJL=$$SETSTR^VALM1(PSJLRN,PSJL,64,10)
SET RNWPRTD=1
End DoDot:1
+7 QUIT
XCHK ;
+1 IF $EXTRACT(X)="?"
WRITE !!?2,"Select order",$EXTRACT("s",PS'=1)," (1"
if PS>1
WRITE "-",PS
WRITE ")."
+2 IF $EXTRACT(X)="?"
if $SELECT($ORDER(^TMP("PSIV",$JOB,PSIVST,ON))
WRITE " Press RETURN to view more orders, or enter '^' to abort",!,"the profile, or 'A' to view Allergies."
if $EXTRACT(X,1,2)="??"
DO H2^PSGON
KILL X
QUIT
+3 SET PSGLMT=PS
DO ^PSGON
QUIT
+4 ;
PSPD SET Y=$SELECT(PSIVST'="P":$PIECE($GET(^PS(55,DFN,"IV",+ON,9)),U),1:"")
+1 XECUTE ^DD("DD")
if Y=""
SET PSJL=$$SETSTR^VALM1("** N/P **",PSJL,36,12)
+2 if Y'=""
SET PSJL=$$SETSTR^VALM1($PIECE(Y,","),PSJL,36,7)
SET PSJL=$$SETSTR^VALM1($PIECE($PIECE(Y,"@",2),":",1,2),PSJL,43,45)
+3 SET PSJL=PSJL_" #"_$SELECT(Y="":0,1:$PIECE(^PS(55,DFN,"IV",+ON,9),U,2))
+4 DO REST
+5 QUIT
