PSIVWL1 ;BIR/RGY-WARD LIST ROUTINES ;02 AUG 96 / 9:40 AM
;;5.0; INPATIENT MEDICATIONS ;**81**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^VA(200 is supported by DBIA 10060
;
SELMAN ;
K PSM,PSIVMT,PSIVOD,PSIVCD S PSCT=0 F I=0:0 S I=$O(^PS(59.5,PSIVSN,2,I)) Q:'I S PSM(I)=^(I,0),PSCT=PSCT+1
P W !!?5,"The manufacturing times on file are:"
P0 F I=0:0 S I=$O(PSM(I)) Q:'I S X=PSM(I) W !?10,I," ",$E($P(X,"^",5),1,2),":",$E($P(X,"^",5),3,4)," ",$$CODES^PSIVUTL($P(X,"^",2),59.51,.02)_" covering ",$P(X,"^",3),"."
ASK ;
S X="Enter manufacturing time(s):^^^^QUX=+QUX!(QUX["","")!(QUX="""")" D ENQ^PSIV Q:X["^"!(X="") S PSM=X F I=1:1 S X=$P(PSM,",",I) Q:X="" I '$D(PSM(X)) S PSM="*" Q
I PSM="*" S HELP="ASKMAN" D ^PSIVHLP G P
SEL F PSIV=1:1 S I=$P(PSM,",",PSIV) Q:I="" S PSIVMT($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^",5)),PSIVOD($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^")),PSIVCD($P(PSM(I),"^",2))=+(PSIVDT_"."_$P(PSM(I),"^",4)) D SEL1
W ! S X=PSM K PSM Q
SEL1 I $P(PSM(I),"^")>$P(PSM(I),"^",4) S X1=PSIVDT,X2=1 D C^%DTC S X=$P(X,".") S $P(PSIVCD($P(PSM(I),"^",2)),".")=X ; INSTALL WITH V 17.3 OF FILEMAN
Q
ENRSET W ! S X="Are you sure you want to RESET the Ward List (Y/N) ?^N" D ENYN^PSIV Q:"N^"[$E(X) I X="?" S HELP="RESWL" D ^PSIVHLP1 G ENRSET
D SELMAN F I=1:1 S Y=$P(X,",",I) Q:'Y S $P(^PS(59.5,PSIVSN,2,Y,0),"^",6)=PSIVDT W !,"... Ward list #",$P(X,",",I)," reset"
Q
PRNT ;
D HDR:$Y+7>IOSL!(PSIVWARD'=WRD),INP^VADPT
W !,VAIN(5),?30 S PSIV=$O(^PS(55,DFN,"IV",ON,"AD",0)) D:PSIV ENP2^PSIVRNL W ?70 S Y=P(3) D WD W ?92,+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),?100 W $P($G(^VA(200,+P(6),0)),U)
W !,PSIV("NME") S SSNF=0 D ENP3^PSIVRNL Q
HDR W:$Y @IOF W !,"WARD LIST FOR IV ROOM: ",$P(^PS(59.5,PSIVSN,0),U)," AT " S Y=PSIVDT X ^DD("DD") W $P(Y,"@"),?70,"Printed on : " S Y=PSIVRUN,UWLTY="" X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) W !
F I=0:0 S UWLTY=$O(PSIVOD(UWLTY)) Q:UWLTY="" S X=$$CODES^PSIVUTL(UWLTY,55.01,.04) W !,X,"S",?15," covering from " S Y=PSIVOD(UWLTY) D WD W " to " S Y=PSIVCD(UWLTY) D WD W " Manufacturing time: " S Y=PSIVMT(UWLTY) D WD
Q:NOFLG=1 W !!?92,"Qty",!,"Patient name",?40,"Order",?70,"Stop date",?90,"needed",?100,"Provider/Initial"
W ! F X=1:1:110 W "-" W:X=50 " Ward: ",WRD," "
S PSIVWARD=WRD
K UWLTY
Q
SETP S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
Q
WD X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) Q
CODES S X=$P($P(";"_$P(Y,"^",3),";"_X_":",2),";") Q
ENT ;
;Will print ward list
NOW D NOW^%DTC S PSIVRUN=$E(%,1,12),PSIVWARD="" K %,%I,%H
S WRD="",NOFLG=1 F JX=0:0 S WRD=$O(^PS(55,"PSIVWL",PSIVSN,WRD)) Q:WRD="" S PSIVT="" F JX=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" S PSIVDT=PSIVOD(PSIVT) D NOW1
W:NOFLG !!,"****NO DATA FOUND FOR THE WARD LIST WITH THE SELECTED IV TYPE(S)!****"
G QPRNT
Q
NOW1 F DFN=0:0 S DFN=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN)) Q:'DFN S PSIV("NME")=$P($G(^DPT(DFN,0)),U) D PID^VADPT,NXT
Q
QPRNT K JX,PSIVT,PSIVWARD,PSIVDT,PSIVRUN,WRD Q
NXT F ON=0:0 S ON=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)) Q:'ON S NOFLG=0 D SETP,PRNT:"DPN"'[P(17)
Q
ENINIT ;
F Z1=0:0 S Z1=$O(^PS(59.5,PSIVSN,2,Z1)) Q:'Z1 S Z2=^(Z1,0),PSIVT="" F PSIV1=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" I $P(PSIVOD(PSIVT),".",2)=$P(+("."_Z2),".",2),(PSIVT=$P(Z2,"^",2)) S $P(^(0),"^",6)=PSIVOD(PSIVT)\1+("."_$P(^(0),"^"))
S Z1="" F PSIV1=0:0 S Z1=$O(^PS(55,"PSIVWL",PSIVSN,Z1)) Q:Z1="" S PSIVT="" F PSIV1=0:0 S PSIVT=$O(^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT)) Q:PSIVT="" D K1
K Z1,Z2 Q
K1 I $E(PSIVT,2,999)<(DT-1) K ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT) Q
S Z2="" F PSIV1=0:0 S Z2=$O(PSIVOD(Z2)) Q:Z2="" K:PSIVT=(Z2_PSIVOD(Z2)) ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVWL1 3813 printed Sep 23, 2025@19:41:24 Page 2
PSIVWL1 ;BIR/RGY-WARD LIST ROUTINES ;02 AUG 96 / 9:40 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**81**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^VA(200 is supported by DBIA 10060
+5 ;
SELMAN ;
+1 KILL PSM,PSIVMT,PSIVOD,PSIVCD
SET PSCT=0
FOR I=0:0
SET I=$ORDER(^PS(59.5,PSIVSN,2,I))
if 'I
QUIT
SET PSM(I)=^(I,0)
SET PSCT=PSCT+1
P WRITE !!?5,"The manufacturing times on file are:"
P0 FOR I=0:0
SET I=$ORDER(PSM(I))
if 'I
QUIT
SET X=PSM(I)
WRITE !?10,I," ",$EXTRACT($PIECE(X,"^",5),1,2),":",$EXTRACT($PIECE(X,"^",5),3,4)," ",$$CODES^PSIVUTL($PIECE(X,"^",2),59.51,.02)_" covering ",$PIECE(X,"^",3),"."
ASK ;
+1 SET X="Enter manufacturing time(s):^^^^QUX=+QUX!(QUX["","")!(QUX="""")"
DO ENQ^PSIV
if X["^"!(X="")
QUIT
SET PSM=X
FOR I=1:1
SET X=$PIECE(PSM,",",I)
if X=""
QUIT
IF '$DATA(PSM(X))
SET PSM="*"
QUIT
+2 IF PSM="*"
SET HELP="ASKMAN"
DO ^PSIVHLP
GOTO P
SEL FOR PSIV=1:1
SET I=$PIECE(PSM,",",PSIV)
if I=""
QUIT
SET PSIVMT($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^",5))
SET PSIVOD($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^"))
SET PSIVCD($PIECE(PSM(I),"^",2))=+(PSIVDT_"."_$PIECE(PSM(I),"^",4))
DO SEL1
+1 WRITE !
SET X=PSM
KILL PSM
QUIT
SEL1 ; INSTALL WITH V 17.3 OF FILEMAN
IF $PIECE(PSM(I),"^")>$PIECE(PSM(I),"^",4)
SET X1=PSIVDT
SET X2=1
DO C^%DTC
SET X=$PIECE(X,".")
SET $PIECE(PSIVCD($PIECE(PSM(I),"^",2)),".")=X
+1 QUIT
ENRSET WRITE !
SET X="Are you sure you want to RESET the Ward List (Y/N) ?^N"
DO ENYN^PSIV
if "N^"[$EXTRACT(X)
QUIT
IF X="?"
SET HELP="RESWL"
DO ^PSIVHLP1
GOTO ENRSET
+1 DO SELMAN
FOR I=1:1
SET Y=$PIECE(X,",",I)
if 'Y
QUIT
SET $PIECE(^PS(59.5,PSIVSN,2,Y,0),"^",6)=PSIVDT
WRITE !,"... Ward list #",$PIECE(X,",",I)," reset"
+2 QUIT
PRNT ;
+1 if $Y+7>IOSL!(PSIVWARD'=WRD)
DO HDR
DO INP^VADPT
+2 WRITE !,VAIN(5),?30
SET PSIV=$ORDER(^PS(55,DFN,"IV",ON,"AD",0))
if PSIV
DO ENP2^PSIVRNL
WRITE ?70
SET Y=P(3)
DO WD
WRITE ?92,+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),?100
WRITE $PIECE($GET(^VA(200,+P(6),0)),U)
+3 WRITE !,PSIV("NME")
SET SSNF=0
DO ENP3^PSIVRNL
QUIT
HDR if $Y
WRITE @IOF
WRITE !,"WARD LIST FOR IV ROOM: ",$PIECE(^PS(59.5,PSIVSN,0),U)," AT "
SET Y=PSIVDT
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@"),?70,"Printed on : "
SET Y=PSIVRUN
SET UWLTY=""
XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
WRITE !
+1 FOR I=0:0
SET UWLTY=$ORDER(PSIVOD(UWLTY))
if UWLTY=""
QUIT
SET X=$$CODES^PSIVUTL(UWLTY,55.01,.04)
WRITE !,X,"S",?15," covering from "
SET Y=PSIVOD(UWLTY)
DO WD
WRITE " to "
SET Y=PSIVCD(UWLTY)
DO WD
WRITE " Manufacturing time: "
SET Y=PSIVMT(UWLTY)
DO WD
+2 if NOFLG=1
QUIT
WRITE !!?92,"Qty",!,"Patient name",?40,"Order",?70,"Stop date",?90,"needed",?100,"Provider/Initial"
+3 WRITE !
FOR X=1:1:110
WRITE "-"
if X=50
WRITE " Ward: ",WRD," "
+4 SET PSIVWARD=WRD
+5 KILL UWLTY
+6 QUIT
SETP SET Y=^PS(55,DFN,"IV",ON,0)
FOR X=1:1:23
SET P(X)=$PIECE(Y,"^",X)
+1 QUIT
WD XECUTE ^DD("DD")
WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
QUIT
CODES SET X=$PIECE($PIECE(";"_$PIECE(Y,"^",3),";"_X_":",2),";")
QUIT
ENT ;
+1 ;Will print ward list
NOW DO NOW^%DTC
SET PSIVRUN=$EXTRACT(%,1,12)
SET PSIVWARD=""
KILL %,%I,%H
+1 SET WRD=""
SET NOFLG=1
FOR JX=0:0
SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD))
if WRD=""
QUIT
SET PSIVT=""
FOR JX=0:0
SET PSIVT=$ORDER(PSIVOD(PSIVT))
if PSIVT=""
QUIT
SET PSIVDT=PSIVOD(PSIVT)
DO NOW1
+2 if NOFLG
WRITE !!,"****NO DATA FOUND FOR THE WARD LIST WITH THE SELECTED IV TYPE(S)!****"
+3 GOTO QPRNT
+4 QUIT
NOW1 FOR DFN=0:0
SET DFN=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN))
if 'DFN
QUIT
SET PSIV("NME")=$PIECE($GET(^DPT(DFN,0)),U)
DO PID^VADPT
DO NXT
+1 QUIT
QPRNT KILL JX,PSIVT,PSIVWARD,PSIVDT,PSIVRUN,WRD
QUIT
NXT FOR ON=0:0
SET ON=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON))
if 'ON
QUIT
SET NOFLG=0
DO SETP
if "DPN"'[P(17)
DO PRNT
+1 QUIT
ENINIT ;
+1 FOR Z1=0:0
SET Z1=$ORDER(^PS(59.5,PSIVSN,2,Z1))
if 'Z1
QUIT
SET Z2=^(Z1,0)
SET PSIVT=""
FOR PSIV1=0:0
SET PSIVT=$ORDER(PSIVOD(PSIVT))
if PSIVT=""
QUIT
IF $PIECE(PSIVOD(PSIVT),".",2)=$PIECE(+("."_Z2),".",2)
IF (PSIVT=$PIECE(Z2,"^",2))
SET $PIECE(^(0),"^",6)=PSIVOD(PSIVT)\1+("."_$PIECE(^(0),"^"))
+2 SET Z1=""
FOR PSIV1=0:0
SET Z1=$ORDER(^PS(55,"PSIVWL",PSIVSN,Z1))
if Z1=""
QUIT
SET PSIVT=""
FOR PSIV1=0:0
SET PSIVT=$ORDER(^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT))
if PSIVT=""
QUIT
DO K1
+3 KILL Z1,Z2
QUIT
K1 IF $EXTRACT(PSIVT,2,999)<(DT-1)
KILL ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)
QUIT
+1 SET Z2=""
FOR PSIV1=0:0
SET Z2=$ORDER(PSIVOD(Z2))
if Z2=""
QUIT
if PSIVT=(Z2_PSIVOD(Z2))
KILL ^PS(55,"PSIVWL",PSIVSN,Z1,PSIVT),^PS(55,"PSIVWLM",PSIVSN,PSIVT)
+2 QUIT
