PSIVRNL ;BIR/RGY-PRINT RENEWAL AND ACTIVE ORDER LIST ; 15 May 98 / 9:27 AM
;;5.0;INPATIENT MEDICATIONS;**3,137,364,425**;16 DEC 97;Build 3
;
ENRNL ;
D ^PSIVXU I $D(XQUIT) K XQUIT Q
D BEGRNL K DFN,I,ON,P,PSIV,PSIV1,PSIVBEG,PSIVDT,PSIVEND,PSIVRUN,WARD,WRD,WRDB,WRDE,VAERR,Z
Q
;
BEGRNL W ! S %DT="EXT",X="Enter beginning date: ^T@0001^^^1" D ENQ^PSIV,^%DT G:X["^" QRNL G:Y<0&(X'="?") BEGRNL I X["?" S HELP="RNL" D ^PSIVHLP G BEGRNL
S PSIVBEG=Y I Y'["." W $C(7),!!,"*** Please enter time with date. ***",! G BEGRNL
ENDRNL W ! S X="Enter ending date: ^T@2400^^^1" D ENQ^PSIV,^%DT G:X["^" QRNL G:Y<0&(X'="?") ENDRNL I X["?" S HELP="RNL" D ^PSIVHLP G ENDRNL
I Y'["." W $C(7),!!,"*** Please enter time with date. ***",! G ENDRNL
EN1 S PSIVEND=Y K WRD
BEG K DIR S DIR(0)="F^1:30",DIR("A")="Start at WARD",DIR("B")="BEG"
S DIR("?")="or enter any ward.",DIR("?",1)="Press <RETURN> to start from the first ward",DIR("?",2)="or enter ""^Outpatient"" for Outpatient IV"
D ^DIR
G QRNL:$D(DTOUT)!("^"[X) I X="BEG" S WRDB="" G END
S X=$$ENLU^PSGMI(X) I "^OUTPATIENT"[X W $P("^OUTPATIENT IV",X,2) S WRDB="Outpatient IV" G END
I X]"" K DA,DIC S DIC="^DIC(42,",DIC(0)="QEM" D ^DIC K DA,DIC G:Y<1 BEG
S WRDB=$P(Y,"^",2)
END K DIR S DIR(0)="F^1:30",DIR("A")="Stop at WARD",DIR("B")="END"
S DIR("?")="or enter any ward.",DIR("?",1)="Press <RETURN> to stop at the last ward",DIR("?",2)="or enter ""^Outpatient"" for Outpatient IV"
D ^DIR
G QRNL:$D(DTOUT)!("^"[X) I X="END" S WRDE="z" G WRD
S X=$$ENLU^PSGMI(X) I "^OUTPATIENT"[X W $P("^OUTPATIENT IV",X,2) S WRDE="Outpatient IV" G WRD
I X]"" K DA,DIC S DIC="^DIC(42,",DIC(0)="QEM" D ^DIC K DA,DIC G:Y<1 END
S WRDE=$P(Y,"^",2)
WRD S WRDB=$E(WRDB,1,$L(WRDB)-1)_$C($A(WRDB,$L(WRDB))-1),WRDE=$E(WRDE,1,$L(WRDE)-1)_$C($A(WRDE,$L(WRDE))+1) K X S X(WRDE)=""
I $O(X(WRDB))'=WRDE W ! K DIR S DIR(0)="E",DIR("A",1)="The starting ward must be alphabetically before the ending ward.",DIR("A")="Press <RETURN> to continue" D ^DIR K X G BEG
I PSIVPR'=ION D QUERNL G QRNL
DEQRNL K ^UTILITY("PSIV",$J) S (WARD,^($J,WRDE))="" D NOW^%DTC S:$E(PSIVEND)=9 PSIVBEG=% S PSIVRUN=$E(%,1,12)
F PSIVDT=PSIVBEG-.0001:0 S PSIVDT=$O(^PS(55,"AIV",PSIVDT)) Q:'PSIVDT!(PSIVDT>PSIVEND) F DFN=0:0 S DFN=$O(^PS(55,"AIV",PSIVDT,DFN)) Q:'DFN D DEQRNL1
S WRD=WRDB F PSIV1=0:0 S WRD=$O(^UTILITY("PSIV",$J,WRD)) Q:WRD=""!(WRDE']WRD) F DFN=0:0 S DFN=$O(^UTILITY("PSIV",$J,WRD,DFN)) Q:'DFN F ON=0:0 S ON=$O(^UTILITY("PSIV",$J,WRD,DFN,ON)) Q:'ON D SETP,CHK
QRNL W:'$D(PSIVPR)&($Y) @IOF K ^UTILITY("PSIV",$J) S:$D(ZTQUEUED) ZTREQ="@" Q
WD X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) Q
SETP S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
Q
;
DEQRNL1 ;
S PSIV("NME")=$P($G(^DPT(DFN,0)),U) D INP^VADPT F ON=0:0 S ON=$O(^PS(55,"AIV",PSIVDT,DFN,ON)) Q:'ON D SETP,UT
Q
PRNT D:$Y+7>IOSL!(WARD'=WRD) HDR D ENIV^PSJAC W !,VAIN(5),?30 S PSIV=$O(^PS(55,DFN,"IV",ON,"AD",0)) D:PSIV ENP2 W ?80 S Y=P(3) D WD W ?105,$P($G(^VA(200,+P(6),0)),"^")
ENP1 W !,VADM(1)
S SSNF=0
ENP3 I PSIV]"" S PSIV=$O(^PS(55,DFN,"IV",ON,"AD",PSIV)) I PSIV D ENP2 W ! D CHK2
N HAZFLG
I PSIV]"" F PSIV=PSIV:0 S PSIV=$O(^PS(55,DFN,"IV",ON,"AD",PSIV)) Q:'PSIV D ENP2 W ! D CHK2
F PSIV=0:0 S PSIV=$O(^PS(55,DFN,"IV",ON,"SOL",PSIV)) Q:'PSIV D
.; naked ref below refers to line above
.S PSIV=PSIV_"^"_^(PSIV,0) W ?30,$S($D(^PS(52.7,$P(PSIV,"^",2),0)):$P(^(0),"^")_" "_$P(PSIV,"^",3)_" "_$P(^(0),"^",4),1:"*** Undefined Solution"),! D CHK2
.;introduces haz handle/dispose warnings-bg *364
.N PSSL,PSHAZ S HAZFLG=0 S PSSL=$P(^PS(52.7,$P(PSIV,"^",2),0),"^",2) S PSHAZ=$$HAZ^PSSUTIL(PSSL) I $P(PSHAZ,"^")=1 S P("HAZHA")="<<HAZ Handle>> " S HAZFLG=1
.I $P(PSHAZ,"^",2)=1 S P("HAZDA")="<<HAZ Dispose>>" S HAZFLG=1
W:P(8)]"" ?30,$P(P(8),"@"),! D CHK2
I $G(HAZFLG) W ?30,$G(P("HAZHA"))_$G(P("HAZDA")) K P("HAZDA"),P("HAZHA") ;*425 IF condition and HAZFLG
W:P(9)]"" ?30,P(9) W:P(11)]"" " (",P(11),")" W:P(9)_P(11)]"" ! D CHK2
S PSIV=$S($D(^PS(55,DFN,"IV",ON,3)):$P(^(3),"^"),1:"") W:PSIV]"" ?30,"Other print info.: ",PSIV,! D CHK2
; naked ref below refers to line above
S PSIV=$S($D(^(1)):$P(^(1),"^"),1:"") W:PSIV]"" ?40,"Remarks: ",PSIV,! D CHK2
I "OHD"[P(17) S Y=^DD(55.01,100,0),X=P(17),X=$P($P(";"_$P(Y,"^",3),";"_X_":",2),";") W ?30,"*** THIS ORDER HAS A STATUS OF '",X,"' ***",!
D CHK2 K SSNF
Q
ENP2 S PSIV=PSIV_"^"_^PS(55,DFN,"IV",ON,"AD",+PSIV,0) W ?30,$S($D(^PS(52.6,$P(PSIV,"^",2),0)):$P(^(0),"^")_" "_$P(PSIV,"^",3),1:"*** Undefined Additive") D
. N PSDG,PSHAZ S PSDG=$P(^PS(52.6,$P(PSIV,"^",2),0),"^",2) S PSHAZ=$$HAZ^PSSUTIL(PSDG) I $P(PSHAZ,"^")=1 S P("HAZHS")="<<HAZ Handle>> "
. I $P(PSHAZ,"^",2)=1 S P("HAZDS")="<<HAZ Dispose>>"
. I $P(PSHAZ,"^")!$P(PSHAZ,"^",2) W !?30,$G(P("HAZHS"))_$G(P("HAZDS")) K P("HAZDS"),P("HAZHS") ;*425 IF condition
. S PSIV=+PSIV Q
I $P(PSIV,"^",4)]"" W " (",$P(PSIV,"^",4),")"
Q
HDR W:$Y @IOF,!! I $E(PSIVEND)=9 W "Active order list"
E W "Renewal list from " S Y=PSIVBEG D WD W " to " S Y=PSIVEND D WD
W !,"Printed on: " S Y=PSIVRUN D WD W !!,"Patient name",?40,"Order",?80,"Stop date",?105,"Provider",! F Y=1:1:130 W "-"
S WARD=WRD W !?50,"**** Ward: ",WRD," ****" W ! Q
QUERNL S ZTIO=PSIVPR,ZTDESC="IV "_$S($E(PSIVEND)=9:"ACTIVE ORDER",1:"RENEWAL")_" LIST",ZTRTN="DEQRNL^PSIVRNL" F X="WRDE","WRDB","PSIVBEG","PSIVEND","PSIVSITE","PSIVSN","PSJSYSW0","PSJSYSU","PSJSYSP","PSJSYSP0" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Queued." G QRNL
UT S ^UTILITY("PSIV",$J,$S($P(VAIN(4),U,2)]"":$P(VAIN(4),U,2),1:"Outpatient IV"),DFN,ON)="" Q
CHK I "DEPN"'[P(17),$P($G(^PS(55,DFN,"IV",ON,2)),U,2)=PSIVSN D:$S($E(PSIVEND)=9:1,1:$P(^(2),U,9)'="R") PRNT
Q
ENTACT D NOW^%DTC S PSIVBEG=%,Y=9999999 G EN1
CHK2 I '$G(SSNF) W VA("BID")," [",ON,"]" S SSNF=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVRNL 5777 printed Oct 16, 2024@18:05:45 Page 2
PSIVRNL ;BIR/RGY-PRINT RENEWAL AND ACTIVE ORDER LIST ; 15 May 98 / 9:27 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**3,137,364,425**;16 DEC 97;Build 3
+2 ;
ENRNL ;
+1 DO ^PSIVXU
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+2 DO BEGRNL
KILL DFN,I,ON,P,PSIV,PSIV1,PSIVBEG,PSIVDT,PSIVEND,PSIVRUN,WARD,WRD,WRDB,WRDE,VAERR,Z
+3 QUIT
+4 ;
BEGRNL WRITE !
SET %DT="EXT"
SET X="Enter beginning date: ^T@0001^^^1"
DO ENQ^PSIV
DO ^%DT
if X["^"
GOTO QRNL
if Y<0&(X'="?")
GOTO BEGRNL
IF X["?"
SET HELP="RNL"
DO ^PSIVHLP
GOTO BEGRNL
+1 SET PSIVBEG=Y
IF Y'["."
WRITE $CHAR(7),!!,"*** Please enter time with date. ***",!
GOTO BEGRNL
ENDRNL WRITE !
SET X="Enter ending date: ^T@2400^^^1"
DO ENQ^PSIV
DO ^%DT
if X["^"
GOTO QRNL
if Y<0&(X'="?")
GOTO ENDRNL
IF X["?"
SET HELP="RNL"
DO ^PSIVHLP
GOTO ENDRNL
+1 IF Y'["."
WRITE $CHAR(7),!!,"*** Please enter time with date. ***",!
GOTO ENDRNL
EN1 SET PSIVEND=Y
KILL WRD
BEG KILL DIR
SET DIR(0)="F^1:30"
SET DIR("A")="Start at WARD"
SET DIR("B")="BEG"
+1 SET DIR("?")="or enter any ward."
SET DIR("?",1)="Press <RETURN> to start from the first ward"
SET DIR("?",2)="or enter ""^Outpatient"" for Outpatient IV"
+2 DO ^DIR
+3 if $DATA(DTOUT)!("^"[X)
GOTO QRNL
IF X="BEG"
SET WRDB=""
GOTO END
+4 SET X=$$ENLU^PSGMI(X)
IF "^OUTPATIENT"[X
WRITE $PIECE("^OUTPATIENT IV",X,2)
SET WRDB="Outpatient IV"
GOTO END
+5 IF X]""
KILL DA,DIC
SET DIC="^DIC(42,"
SET DIC(0)="QEM"
DO ^DIC
KILL DA,DIC
if Y<1
GOTO BEG
+6 SET WRDB=$PIECE(Y,"^",2)
END KILL DIR
SET DIR(0)="F^1:30"
SET DIR("A")="Stop at WARD"
SET DIR("B")="END"
+1 SET DIR("?")="or enter any ward."
SET DIR("?",1)="Press <RETURN> to stop at the last ward"
SET DIR("?",2)="or enter ""^Outpatient"" for Outpatient IV"
+2 DO ^DIR
+3 if $DATA(DTOUT)!("^"[X)
GOTO QRNL
IF X="END"
SET WRDE="z"
GOTO WRD
+4 SET X=$$ENLU^PSGMI(X)
IF "^OUTPATIENT"[X
WRITE $PIECE("^OUTPATIENT IV",X,2)
SET WRDE="Outpatient IV"
GOTO WRD
+5 IF X]""
KILL DA,DIC
SET DIC="^DIC(42,"
SET DIC(0)="QEM"
DO ^DIC
KILL DA,DIC
if Y<1
GOTO END
+6 SET WRDE=$PIECE(Y,"^",2)
WRD SET WRDB=$EXTRACT(WRDB,1,$LENGTH(WRDB)-1)_$CHAR($ASCII(WRDB,$LENGTH(WRDB))-1)
SET WRDE=$EXTRACT(WRDE,1,$LENGTH(WRDE)-1)_$CHAR($ASCII(WRDE,$LENGTH(WRDE))+1)
KILL X
SET X(WRDE)=""
+1 IF $ORDER(X(WRDB))'=WRDE
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A",1)="The starting ward must be alphabetically before the ending ward."
SET DIR("A")="Press <RETURN> to continue"
DO ^DIR
KILL X
GOTO BEG
+2 IF PSIVPR'=ION
DO QUERNL
GOTO QRNL
DEQRNL KILL ^UTILITY("PSIV",$JOB)
SET (WARD,^($JOB,WRDE))=""
DO NOW^%DTC
if $EXTRACT(PSIVEND)=9
SET PSIVBEG=%
SET PSIVRUN=$EXTRACT(%,1,12)
+1 FOR PSIVDT=PSIVBEG-.0001:0
SET PSIVDT=$ORDER(^PS(55,"AIV",PSIVDT))
if 'PSIVDT!(PSIVDT>PSIVEND)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^PS(55,"AIV",PSIVDT,DFN))
if 'DFN
QUIT
DO DEQRNL1
+2 SET WRD=WRDB
FOR PSIV1=0:0
SET WRD=$ORDER(^UTILITY("PSIV",$JOB,WRD))
if WRD=""!(WRDE']WRD)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^UTILITY("PSIV",$JOB,WRD,DFN))
if 'DFN
QUIT
FOR ON=0:0
SET ON=$ORDER(^UTILITY("PSIV",$JOB,WRD,DFN,ON))
if 'ON
QUIT
DO SETP
DO CHK
QRNL if '$DATA(PSIVPR)&($Y)
WRITE @IOF
KILL ^UTILITY("PSIV",$JOB)
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
WD XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
QUIT
SETP SET Y=^PS(55,DFN,"IV",ON,0)
FOR X=1:1:23
SET P(X)=$PIECE(Y,"^",X)
+1 QUIT
+2 ;
DEQRNL1 ;
+1 SET PSIV("NME")=$PIECE($GET(^DPT(DFN,0)),U)
DO INP^VADPT
FOR ON=0:0
SET ON=$ORDER(^PS(55,"AIV",PSIVDT,DFN,ON))
if 'ON
QUIT
DO SETP
DO UT
+2 QUIT
PRNT if $Y+7>IOSL!(WARD'=WRD)
DO HDR
DO ENIV^PSJAC
WRITE !,VAIN(5),?30
SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"AD",0))
if PSIV
DO ENP2
WRITE ?80
SET Y=P(3)
DO WD
WRITE ?105,$PIECE($GET(^VA(200,+P(6),0)),"^")
ENP1 WRITE !,VADM(1)
+1 SET SSNF=0
ENP3 IF PSIV]""
SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"AD",PSIV))
IF PSIV
DO ENP2
WRITE !
DO CHK2
+1 NEW HAZFLG
+2 IF PSIV]""
FOR PSIV=PSIV:0
SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"AD",PSIV))
if 'PSIV
QUIT
DO ENP2
WRITE !
DO CHK2
+3 FOR PSIV=0:0
SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"SOL",PSIV))
if 'PSIV
QUIT
Begin DoDot:1
+4 ; naked ref below refers to line above
+5 SET PSIV=PSIV_"^"_^(PSIV,0)
WRITE ?30,$SELECT($DATA(^PS(52.7,$PIECE(PSIV,"^",2),0)):$PIECE(^(0),"^")_" "_$PIECE(PSIV,"^",3)_" "_$PIECE(^(0),"^",4),1:"*** Undefined Solution"),!
DO CHK2
+6 ;introduces haz handle/dispose warnings-bg *364
+7 NEW PSSL,PSHAZ
SET HAZFLG=0
SET PSSL=$PIECE(^PS(52.7,$PIECE(PSIV,"^",2),0),"^",2)
SET PSHAZ=$$HAZ^PSSUTIL(PSSL)
IF $PIECE(PSHAZ,"^")=1
SET P("HAZHA")="<<HAZ Handle>> "
SET HAZFLG=1
+8 IF $PIECE(PSHAZ,"^",2)=1
SET P("HAZDA")="<<HAZ Dispose>>"
SET HAZFLG=1
End DoDot:1
+9 if P(8)]""
WRITE ?30,$PIECE(P(8),"@"),!
DO CHK2
+10 ;*425 IF condition and HAZFLG
IF $GET(HAZFLG)
WRITE ?30,$GET(P("HAZHA"))_$GET(P("HAZDA"))
KILL P("HAZDA"),P("HAZHA")
+11 if P(9)]""
WRITE ?30,P(9)
if P(11)]""
WRITE " (",P(11),")"
if P(9)_P(11)]""
WRITE !
DO CHK2
+12 SET PSIV=$SELECT($DATA(^PS(55,DFN,"IV",ON,3)):$PIECE(^(3),"^"),1:"")
if PSIV]""
WRITE ?30,"Other print info.: ",PSIV,!
DO CHK2
+13 ; naked ref below refers to line above
+14 SET PSIV=$SELECT($DATA(^(1)):$PIECE(^(1),"^"),1:"")
if PSIV]""
WRITE ?40,"Remarks: ",PSIV,!
DO CHK2
+15 IF "OHD"[P(17)
SET Y=^DD(55.01,100,0)
SET X=P(17)
SET X=$PIECE($PIECE(";"_$PIECE(Y,"^",3),";"_X_":",2),";")
WRITE ?30,"*** THIS ORDER HAS A STATUS OF '",X,"' ***",!
+16 DO CHK2
KILL SSNF
+17 QUIT
ENP2 SET PSIV=PSIV_"^"_^PS(55,DFN,"IV",ON,"AD",+PSIV,0)
WRITE ?30,$SELECT($DATA(^PS(52.6,$PIECE(PSIV,"^",2),0)):$PIECE(^(0),"^")_" "_$PIECE(PSIV,"^",3),1:"*** Undefined Additive")
Begin DoDot:1
+1 NEW PSDG,PSHAZ
SET PSDG=$PIECE(^PS(52.6,$PIECE(PSIV,"^",2),0),"^",2)
SET PSHAZ=$$HAZ^PSSUTIL(PSDG)
IF $PIECE(PSHAZ,"^")=1
SET P("HAZHS")="<<HAZ Handle>> "
+2 IF $PIECE(PSHAZ,"^",2)=1
SET P("HAZDS")="<<HAZ Dispose>>"
+3 ;*425 IF condition
IF $PIECE(PSHAZ,"^")!$PIECE(PSHAZ,"^",2)
WRITE !?30,$GET(P("HAZHS"))_$GET(P("HAZDS"))
KILL P("HAZDS"),P("HAZHS")
+4 SET PSIV=+PSIV
QUIT
End DoDot:1
+5 IF $PIECE(PSIV,"^",4)]""
WRITE " (",$PIECE(PSIV,"^",4),")"
+6 QUIT
HDR if $Y
WRITE @IOF,!!
IF $EXTRACT(PSIVEND)=9
WRITE "Active order list"
+1 IF '$TEST
WRITE "Renewal list from "
SET Y=PSIVBEG
DO WD
WRITE " to "
SET Y=PSIVEND
DO WD
+2 WRITE !,"Printed on: "
SET Y=PSIVRUN
DO WD
WRITE !!,"Patient name",?40,"Order",?80,"Stop date",?105,"Provider",!
FOR Y=1:1:130
WRITE "-"
+3 SET WARD=WRD
WRITE !?50,"**** Ward: ",WRD," ****"
WRITE !
QUIT
QUERNL SET ZTIO=PSIVPR
SET ZTDESC="IV "_$SELECT($EXTRACT(PSIVEND)=9:"ACTIVE ORDER",1:"RENEWAL")_" LIST"
SET ZTRTN="DEQRNL^PSIVRNL"
FOR X="WRDE","WRDB","PSIVBEG","PSIVEND","PSIVSITE","PSIVSN","PSJSYSW0","PSJSYSU","PSJSYSP","PSJSYSP0"
SET ZTSAVE(X)=""
+1 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
GOTO QRNL
UT SET ^UTILITY("PSIV",$JOB,$SELECT($PIECE(VAIN(4),U,2)]"":$PIECE(VAIN(4),U,2),1:"Outpatient IV"),DFN,ON)=""
QUIT
CHK IF "DEPN"'[P(17)
IF $PIECE($GET(^PS(55,DFN,"IV",ON,2)),U,2)=PSIVSN
if $SELECT($EXTRACT(PSIVEND)=9
DO PRNT
+1 QUIT
ENTACT DO NOW^%DTC
SET PSIVBEG=%
SET Y=9999999
GOTO EN1
CHK2 IF '$GET(SSNF)
WRITE VA("BID")," [",ON,"]"
SET SSNF=1
QUIT
