PSJLMPRI ;BIR/MLM-INPATIENT LISTMAN IV PROFILE UTILITIES ;01 JUL 96 / 2:24 PM
;;5.0; INPATIENT MEDICATIONS ;**58,85,118,110,133,154**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
PIV(DFN,ON,PSJF,DN) ;Setup LM display for IV order.
N ND14,DRG,ON55,P,PSJORIFN,TYP,V,X,Y,PSJFLAG S TYP="?" I ON["V" D
.S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
.S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
.S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
.S P("PRY")=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,4),PSJFLAG=$P($G(^(.2)),U,7)
.S ND4=$G(^PS(55,DFN,"IV",+ON,4)),V=$S(P("PRY")="D":"d",1:" ")_$S((+PSJSYSU=1&'+$P(ND4,U)):"->",(+PSJSYSU=3&'+$P(ND4,U,4)):"->",1:"") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
.S PSJL=$$SETSTR^VALM1(V,PSJL,6,3)
.S ND14=$G(^PS(55,DFN,"IV",+ON,14,0)),ND14=$P(ND14,U,3) S:ND14 ND14=+$G(^(ND14,0))
I ON=+ON N PSJEN2,O S PSJEN2=PSJEN,O="" F S O=$O(^PS(53.1,"ACX",ON,O)) Q:O="" D
.I PSJEN2'=PSJEN S PSJL=$J(PSJEN2,4)
.S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+O,O)),U,9),Y=+$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U),PSJFLAG=$P($G(^(.2)),U,7)
.D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) D @$S($E(P("OT"))'="F":"PUD^PSJLMPRU(DFN,O_""P"",PSJF,DN)",1:"PIV^PSJLMPRI(DFN,O_""P"",PSJF,DN)") S PSJEN2=""
I ON["P" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U),PSJFLAG=$P($G(^(.2)),U,7) D I $E(P("OT"))'="F" D PUD^PSJLMPRU(DFN,ON,PSJF,DN) Q
. D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
. S ND14=$G(^PS(53.1,+ON,14,0)),ND14=$P(ND14,U,3) S:ND14 ND14=+$G(^(ND14,0))
I $G(PSJFLAG) D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
NEW PSJIVFLG S PSJIVFLG=1
S DRG=+$O(DRG("AD",0)) D:DRG PIVAD F S DRG=$O(DRG("AD",DRG)) Q:'DRG S PSJL="" D PIVAD
SOL ;
S PSJL=$S($G(PSJIVFLG):PSJL_$S(ON["V":"in",1:" in"),1:" in")
NEW DRGX,NAME
S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP,SETSTAT S PSJL=" "
;S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:'$G(PSJIVFLG) SETTMP D:$G(PSJIVFLG) PIV1 S PSJL=" "
Q
PIVAD ; Print IV Additives.
NEW NAME
D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1)
I $D(NAME(2)) S PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP,SETSTAT S PSJL="",PSJL=$$SETSTR^VALM1(NAME(2),PSJL,9,60) D SETTMP,SETSTAT
I '$D(NAME(2)) S PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP,SETSTAT
Q
;
PIV1 ; Print Sched type, start/stop dates, and status.
K PSJIVFLG
F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
I $G(ND14) S ND14=$$ENDTC^PSGMI((ND14)) S PSJL=$$SETSTR^VALM1(ND14,PSJL,$S($D(PSJEXTP):75,1:72),5) K ND14
;* D SETTMP
Q
SETTMP ;
S ^TMP($S($G(PSIVLBNM)]"":PSIVLBNM,1:"PSJPRO"),$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
Q
;
SETSTAT ;
I ON["P",$P($G(^PS(53.1,+ON,.2)),"^",4)="S" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0)
Q
;
LASTREN(DFN,ON) ;
N FIL,RNDT,ND0,ND14 S ND14="" I '$G(ON)!'$G(DFN) Q 0
S FIL=$S(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
Q:FIL="" 0
S ND14=$G(@(FIL)) I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0))
Q ND14
;
LASTRNBY(DFN,ON) ;
N FIL,RNBY,ND0,ND14 S RNBY=""
S FIL=$S(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
Q:FIL="" 0
S ND14=$G(@(FIL)) I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNBY=$P(ND14,"^",2)
Q RNBY
PSJLMPRI ;BIR/MLM-INPATIENT LISTMAN IV PROFILE UTILITIES ;01 JUL 96 / 2:24 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**58,85,118,110,133,154**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
PIV(DFN,ON,PSJF,DN) ;Setup LM display for IV order.
+1 NEW ND14,DRG,ON55,P,PSJORIFN,TYP,V,X,Y,PSJFLAG
SET TYP="?"
IF ON["V"
Begin DoDot:1
+2 SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
FOR X=2,3,4,5,8,9,17,23
SET P(X)=$PIECE(Y,U,X)
+3 SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
IF TYP'="O"
SET TYP="C"
+4 SET ON55=ON
SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")
DO GTDRG^PSIVORFB
DO GTOT^PSIVUTL(P(4))
+5 SET P("PRY")=$PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),U,4)
SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
+6 SET ND4=$GET(^PS(55,DFN,"IV",+ON,4))
SET V=$SELECT(P("PRY")="D":"d",1:" ")_$SELECT((+PSJSYSU=1&'+$PIECE(ND4,U)):"->",(+PSJSYSU=3&'+$PIECE(ND4,U,4)):"->",1:"")
IF PSJFLAG
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+7 SET PSJL=$$SETSTR^VALM1(V,PSJL,6,3)
+8 SET ND14=$GET(^PS(55,DFN,"IV",+ON,14,0))
SET ND14=$PIECE(ND14,U,3)
IF ND14
SET ND14=+$GET(^(ND14,0))
End DoDot:1
+9 IF ON=+ON
NEW PSJEN2,O
SET PSJEN2=PSJEN
SET O=""
FOR
SET O=$ORDER(^PS(53.1,"ACX",ON,O))
IF O=""
QUIT
Begin DoDot:1
+10 IF PSJEN2'=PSJEN
SET PSJL=$JUSTIFY(PSJEN2,4)
+11 SET (P(2),P(3))=""
SET P(17)=$PIECE($GET(^PS(53.1,+O,O)),U,9)
SET Y=+$GET(^(8))
SET P(4)=$PIECE(Y,U)
SET P(8)=$PIECE(Y,U,5)
SET P(9)=$PIECE($GET(^(2)),U)
SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
+12 DO GTDRG^PSIVORFA
DO GTOT^PSIVUTL(P(4))
DO @$SELECT($EXTRACT(P("OT"))'="F":"PUD^PSJLMPRU(DFN,O_""P"",PSJF,DN)",1:"PIV^PSJLMPRI(DFN,O_""P"",PSJF,DN)")
SET PSJEN2=""
End DoDot:1
+13 IF ON["P"
SET (P(2),P(3))=""
SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
SET Y=$GET(^(8))
SET P(4)=$PIECE(Y,U)
SET P(8)=$PIECE(Y,U,5)
SET P(9)=$PIECE($GET(^(2)),U)
SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
Begin DoDot:1
+14 DO GTDRG^PSIVORFA
DO GTOT^PSIVUTL(P(4))
+15 SET ND14=$GET(^PS(53.1,+ON,14,0))
SET ND14=$PIECE(ND14,U,3)
IF ND14
SET ND14=+$GET(^(ND14,0))
End DoDot:1
IF $EXTRACT(P("OT"))'="F"
DO PUD^PSJLMPRU(DFN,ON,PSJF,DN)
QUIT
+16 IF $GET(PSJFLAG)
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+17 NEW PSJIVFLG
SET PSJIVFLG=1
+18 SET DRG=+$ORDER(DRG("AD",0))
IF DRG
DO PIVAD
FOR
SET DRG=$ORDER(DRG("AD",DRG))
IF 'DRG
QUIT
SET PSJL=""
DO PIVAD
SOL ;
+1 SET PSJL=$SELECT($GET(PSJIVFLG):PSJL_$SELECT(ON["V":"in",1:" in"),1:" in")
+2 NEW DRGX,NAME
+3 SET DRG=0
FOR
SET DRG=+$ORDER(DRG("SOL",DRG))
IF 'DRG
QUIT
DO NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0)
SET DRGX=0
FOR
SET DRGX=$ORDER(NAME(DRGX))
IF 'DRGX
QUIT
SET PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60)
IF $GET(PSJIVFLG)
DO PIV1
DO SETTMP
DO SETSTAT
SET PSJL=" "
+4 ;S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:'$G(PSJIVFLG) SETTMP D:$G(PSJIVFLG) PIV1 S PSJL=" "
+5 QUIT
PIVAD ; Print IV Additives.
+1 NEW NAME
+2 DO NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1)
+3 IF $DATA(NAME(2))
SET PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,60)
IF $GET(PSJIVFLG)
DO PIV1
DO SETTMP
DO SETSTAT
SET PSJL=""
SET PSJL=$$SETSTR^VALM1(NAME(2),PSJL,9,60)
DO SETTMP
DO SETSTAT
+4 IF '$DATA(NAME(2))
SET PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,60)
IF $GET(PSJIVFLG)
DO PIV1
DO SETTMP
DO SETSTAT
+5 QUIT
+6 ;
PIV1 ; Print Sched type, start/stop dates, and status.
+1 KILL PSJIVFLG
+2 FOR X=2,3
SET P(X)=$EXTRACT($$ENDTC^PSGMI(P(X)),1,$SELECT($DATA(PSJEXTP):8,1:5))
+3 IF '$DATA(PSJEXTP)
SET PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
SET PSJL=$$SETSTR^VALM1(P(2),PSJL,53,7)
SET PSJL=$$SETSTR^VALM1(P(3),PSJL,60,7)
SET PSJL=$$SETSTR^VALM1(P(17),PSJL,67,1)
+4 IF '$TEST
SET PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
SET PSJL=$$SETSTR^VALM1(P(2),53,7)
SET PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7)
SET PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
+5 IF $GET(ND14)
SET ND14=$$ENDTC^PSGMI((ND14))
SET PSJL=$$SETSTR^VALM1(ND14,PSJL,$SELECT($DATA(PSJEXTP):75,1:72),5)
KILL ND14
+6 ;* D SETTMP
+7 QUIT
SETTMP ;
+1 SET ^TMP($SELECT($GET(PSIVLBNM)]"":PSIVLBNM,1:"PSJPRO"),$JOB,PSJLN,0)=PSJL
SET PSJLN=PSJLN+1
+2 QUIT
+3 ;
SETSTAT ;
+1 IF ON["P"
IF $PIECE($GET(^PS(53.1,+ON,.2)),"^",4)="S"
DO CNTRL^VALM10((PSJLN-1),9,9+$LENGTH(PSJL),IOINHI_IOBON,IOINORM,0)
+2 QUIT
+3 ;
LASTREN(DFN,ON) ;
+1 NEW FIL,RNDT,ND0,ND14
SET ND14=""
IF '$GET(ON)!'$GET(DFN)
QUIT 0
+2 SET FIL=$SELECT(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
+3 ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
+4 IF FIL=""
QUIT 0
+5 SET ND14=$GET(@(FIL))
IF $PIECE(ND14,"^",3)
SET ND14=$GET(^($PIECE(ND14,"^",3),0))
+6 QUIT ND14
+7 ;
LASTRNBY(DFN,ON) ;
+1 NEW FIL,RNBY,ND0,ND14
SET RNBY=""
+2 SET FIL=$SELECT(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
+3 ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
+4 IF FIL=""
QUIT 0
+5 SET ND14=$GET(@(FIL))
IF $PIECE(ND14,"^",3)
SET ND14=$GET(^($PIECE(ND14,"^",3),0))
SET RNBY=$PIECE(ND14,"^",2)
+6 QUIT RNBY
