PSIVUWL ;BIR/RGY,PR-UPDATE DAILY WARD LIST ;01 OCT 96 / 9:42 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
START S PSIVWARD="",Y=1 W !!,"Edit list for: TODAY//" R X:DTIME S:'$T X="^" S:X="" X="T" G Q:X["^" I X'["?" S %DT="EXT" D ^%DT
G:Y<1 START
I X["?" S HELP="UWL" D ^PSIVHLP S X="?" D ^%DT G START
S PSIVDT=Y\1 D ^PSIVWL1 G:'$D(PSIVOD)!('$D(PSIVCD)) Q
BEG R !!,"Enter a WARD, '^OUTPATIENT' or '^ALL': ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X Q I X["?" S HELP="ZW" D ^PSIVHLP2 K DIC S DIC=42,DIC(0)="QEM" D ^DIC K DIC G BEG
S Y=$S("^ALL"[X:"^ALL","^OUTPATIENT"[X:"^OPT IV",1:"") W:Y'="" $P(Y,X,2) S:Y["^OPT IV" Y="^Outpatient IV"
I Y="" K DIC S D=0,DIC(0)="QEM",DIC=42 D IX^DIC K DIC
G:Y<0 BEG S (WRD,WARD)=$P(Y,"^",2) S:WRD="ALL" WRD=$O(^PS(55,"PSIVWL",PSIVSN,"")) G:WRD="" BEG
WARD S (X,PSIVT)="" F PSIV=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" S PSIVDT=PSIVOD(PSIVT) F DFN=0:0 S DFN=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN)) Q:DFN="" D ENIV^PSJAC,UPD1 G:X="^" BEG
I WARD="ALL" S WRD=$O(^PS(55,"PSIVWL",PSIVSN,WRD)) G:WRD="" Q G WARD
Q K %DT,%T,D,DFN,DIC,I,ON,PSIV,PSIVDT,PSIVNOW,PSIVOD,PSIVCD,PSIVMT,PSIVT,PSIVWARD,PSCT,PSM,WARD,WRD,Z,ZTSK D ENIVKV^PSGSETU Q
UPD1 S X="X" F ON=0:0 S ON=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)) Q:'ON!(X="^") D UPD
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
UPD Q:'$D(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)) N ON55,PSIVAC S PSIVAC="PRO",ON55=ON D GT55^PSIVORFB,ENNONUM^PSIVORV2(DFN,ON)
ASK K DIC S X="# of labels ^"_+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)_$S(+^(ON)'=($L($P(^(ON),"^",2)," ")-1):"*",1:"")_"^^DC ORDER,ON CALL,HOLD^QUX=+QUX!($E(QUX)=""^"")" D ENQ^PSIV Q:"^"[X I $E(X)="^" D FIND G:PSIVT]"" UPD Q
I X["?" S HELP="UWL" D ^PSIVHLP1 G ASK
I "DOH"[$E(X) S UWLFLAG="1.001",(PSIVAC,XX)=$E(X) D ^PSIVOPT K UWLFLAG,PSIVAC S X=XX Q
I X'=+X W $C(7)," ???" G ASK
S $P(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),"^")=X Q
FIND ;
S X=$P(X,"^",2),DIC="^DPT(",DIC(0)="QEM" D ^DIC I Y<0 S PSIVT="" Q
S DFN=+Y D ENIV^PSJAC
S WRD=$S($P(VAIN(4),U,2)]"":$P(VAIN(4),U,2),1:"Outpatient IV")
A S X="Enter order number #:^^^^QUX?.N" D ENQ^PSIV S ON=X S:"^"[X PSIVT="" Q:"^"[X I X["?" S HELP="ONUWL" D ^PSIVHLP1 G A
S PSIVT="" F PSIV=0:0 S PSIVT=$O(PSIVOD(PSIVT)) Q:PSIVT="" I $D(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON)) S PSIVDT=PSIVOD(PSIVT) Q
Q:PSIVT'=""
W $C(7),!!,"Patient and order number not found !" G A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVUWL 2576 printed Sep 23, 2025@19:41:19 Page 2
PSIVUWL ;BIR/RGY,PR-UPDATE DAILY WARD LIST ;01 OCT 96 / 9:42 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
START SET PSIVWARD=""
SET Y=1
WRITE !!,"Edit list for: TODAY//"
READ X:DTIME
if '$TEST
SET X="^"
if X=""
SET X="T"
if X["^"
GOTO Q
IF X'["?"
SET %DT="EXT"
DO ^%DT
+1 if Y<1
GOTO START
+2 IF X["?"
SET HELP="UWL"
DO ^PSIVHLP
SET X="?"
DO ^%DT
GOTO START
+3 SET PSIVDT=Y\1
DO ^PSIVWL1
if '$DATA(PSIVOD)!('$DATA(PSIVCD))
GOTO Q
BEG READ !!,"Enter a WARD, '^OUTPATIENT' or '^ALL': ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO Q
IF X["?"
SET HELP="ZW"
DO ^PSIVHLP2
KILL DIC
SET DIC=42
SET DIC(0)="QEM"
DO ^DIC
KILL DIC
GOTO BEG
+1 SET Y=$SELECT("^ALL"[X:"^ALL","^OUTPATIENT"[X:"^OPT IV",1:"")
if Y'=""
WRITE $PIECE(Y,X,2)
if Y["^OPT IV"
SET Y="^Outpatient IV"
+2 IF Y=""
KILL DIC
SET D=0
SET DIC(0)="QEM"
SET DIC=42
DO IX^DIC
KILL DIC
+3 if Y<0
GOTO BEG
SET (WRD,WARD)=$PIECE(Y,"^",2)
if WRD="ALL"
SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,""))
if WRD=""
GOTO BEG
WARD SET (X,PSIVT)=""
FOR PSIV=0:0
SET PSIVT=$ORDER(PSIVOD(PSIVT))
if PSIVT=""
QUIT
SET PSIVDT=PSIVOD(PSIVT)
FOR DFN=0:0
SET DFN=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN))
if DFN=""
QUIT
DO ENIV^PSJAC
DO UPD1
if X="^"
GOTO BEG
+1 IF WARD="ALL"
SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD))
if WRD=""
GOTO Q
GOTO WARD
Q KILL %DT,%T,D,DFN,DIC,I,ON,PSIV,PSIVDT,PSIVNOW,PSIVOD,PSIVCD,PSIVMT,PSIVT,PSIVWARD,PSCT,PSM,WARD,WRD,Z,ZTSK
DO ENIVKV^PSGSETU
QUIT
UPD1 SET X="X"
FOR ON=0:0
SET ON=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON))
if 'ON!(X="^")
QUIT
DO UPD
+1 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
UPD if '$DATA(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON))
QUIT
NEW ON55,PSIVAC
SET PSIVAC="PRO"
SET ON55=ON
DO GT55^PSIVORFB
DO ENNONUM^PSIVORV2(DFN,ON)
ASK KILL DIC
SET X="# of labels ^"_+^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON)_$SELECT(+^(ON)'=($LENGTH($PIECE(^(ON),"^",2)," ")-1):"*",1:"")_"^^DC ORDER,ON CALL,HOLD^QUX=+QUX!($E(QUX)=""^"")"
DO ENQ^PSIV
if "^"[X
QUIT
IF $EXTRACT(X)="^"
DO FIND
if PSIVT]""
GOTO UPD
QUIT
+1 IF X["?"
SET HELP="UWL"
DO ^PSIVHLP1
GOTO ASK
+2 IF "DOH"[$EXTRACT(X)
SET UWLFLAG="1.001"
SET (PSIVAC,XX)=$EXTRACT(X)
DO ^PSIVOPT
KILL UWLFLAG,PSIVAC
SET X=XX
QUIT
+3 IF X'=+X
WRITE $CHAR(7)," ???"
GOTO ASK
+4 SET $PIECE(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_+PSIVDT,DFN,ON),"^")=X
QUIT
FIND ;
+1 SET X=$PIECE(X,"^",2)
SET DIC="^DPT("
SET DIC(0)="QEM"
DO ^DIC
IF Y<0
SET PSIVT=""
QUIT
+2 SET DFN=+Y
DO ENIV^PSJAC
+3 SET WRD=$SELECT($PIECE(VAIN(4),U,2)]"":$PIECE(VAIN(4),U,2),1:"Outpatient IV")
A SET X="Enter order number #:^^^^QUX?.N"
DO ENQ^PSIV
SET ON=X
if "^"[X
SET PSIVT=""
if "^"[X
QUIT
IF X["?"
SET HELP="ONUWL"
DO ^PSIVHLP1
GOTO A
+1 SET PSIVT=""
FOR PSIV=0:0
SET PSIVT=$ORDER(PSIVOD(PSIVT))
if PSIVT=""
QUIT
IF $DATA(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVT_PSIVOD(PSIVT),DFN,ON))
SET PSIVDT=PSIVOD(PSIVT)
QUIT
+2 if PSIVT'=""
QUIT
+3 WRITE $CHAR(7),!!,"Patient and order number not found !"
GOTO A
