PSIVRD ;BIR/PR,MLM-HANDLE QUICK RET/DES ENTRY ;29 SEP 97 / 11:17 AM
;;5.0;INPATIENT MEDICATIONS;**38,58,88,279,407**;16 DEC 97;Build 26
; ;
; Reference to ^PS(55 is supported by DBIA 2191
;
EN ; Entry point to enter returns/destroyed items.
D ^PSIVXU Q:$D(XQUIT)!($G(DONE)) F D ENGETP^PSIV Q:DFN<0 D EN1 ;P407 Added DONE
Q K ACTION,D,DFN,DIC,DIR,DRG,DRGI,DRGN,E,E1,HELP,I,I1,JJ,LABELS,MXMN,ON,ON55,ONCNT,P,PS,PSGDT,PSGID,PSGP,PSGLMT,PSGODDD,PSIVAC,PSIVC,PSIVNOL,PSIVNOW,PSIVON
K PSIVPL,PSIVPR,PSIVSITE,PSIVUP,PSIVX,PSJORIFN,PSJORL,PSJHT,PSJPWT,PSJSYSL,PSJSYSU,PSJSYSW,PSJSYSW0,Q,UL80,VA,VADM,VAIN,VAERR,PSIVNU,PSIVOV1,PSIVOV2,PSIVSN,RDFLAG,RDWARD,X,XQUIT,Y
Q
;
EN1 ;
S PSIVBR="D PROCESS^PSIVRD" D ENCHS1^PSIV
Q
EN1OLD ;
;S PSIVAC="RD" D ENNB^PSIVACT I P("PT")'="N" D GTORDRS Q
ORDNO ;
F R !!,"Enter the order number(s) to be processed: ",PSIVNU:DTIME Q:"^"[PSIVNU D READ
Q
;
READ ; Read order no.s, no profile.
N DONE I '$T!(PSIVNU="^")!(PSIVNU="") S PSIVNU="" Q
I PSIVNU["?" W !!,"Enter order number(s) separated by a comma e.g. 2,4,5,6.",! Q
I PSIVNU[" " W $C(7),$C(7),"??",!! Q
F I=1:1:$L(PSIVNU,",") S ON=$P(PSIVNU,",",I) D
.I $L(ON)'>0 W $C(7),$C(7),"??",!! S DONE=1
.F JJ=1:1:$L(ON) Q:$G(DONE) I $A($E(ON,JJ))<48!($A($E(ON,JJ))>57) W !!,$C(7),$C(7),"Order ",ON," is invalid.",!! S DONE=1
I '$G(DONE) F I=1:1:$L(PSIVNU,",") S ON=$P(PSIVNU,",",I) I '$D(^PS(55,DFN,"IV",+ON,0)) W !!,$C(7),$C(7),"Order number ",+ON," does not exist for this patient.",! S DONE=1
I '$G(DONE) D NOW^%DTC S PSIVNOW=% F ONCNT=1:1:$L(PSIVNU,",") D S ON=9999999999-$P(PSIVNU,",",ONCNT) D OV1
.S X=$G(^PS(55,DFN,"IV",+ON,0)) I $P(X,U,3)<PSIVNOW,("AR"[$P(X,U,17)) S $P(^PS(55,DFN,"IV",+ON,0),U,17)="E" D EXPIR^PSIVOE
Q
;**********************************************************
;* GTORDRS, ASK, OV subroutines are no longer use in 5.0. *
;**********************************************************
GTORDRS ;Needs PSIVBR (Branch point)
S IOP="HOME" D ^%ZIS K %ZIS,IOP Q:P("PT")="N"
D ^PSIVPRO Q:X="^" I X]"" G OV
ASK Q:PS<1 W !!,"Choose 1-",PS,": " R X:DTIME S:'$T X="^" Q:"^"[X
I X?1."?" S HELP="CHSE" D ^PSIVHLP D:X?2."?" H2^PSGON G ASK
S PSGLMT=PS D ^PSGON G:'$D(X) ASK
OV ;
W ! F PSIVOV1=1:1:PSGODDD F PSIVOV2=1:1:$L(PSGODDD(PSIVOV1),",")-1 S ON=+$P(PSGODDD(PSIVOV1),",",PSIVOV2),ON=$S($D(^TMP("PSIV",$J,"AB",ON)):^(ON),$D(^TMP("PSIV",$J,"NB",ON)):^(ON),$D(^TMP("PSIV",$J,"XB",ON)):^(ON),1:"") Q:'ON D OV1
Q
OV1 ;
S (ON,ON55,P("PON"))=9999999999-ON_"V" K PSIVNUM D GT55^PSIVORFB,ENNONUM^PSIVORV2(DFN,ON)
D PROCESS1
Q
;
PROCESS ;
D FULL^VALM1
S PSJORD=ON D ENNH^PSIVORV2(ON)
PROCESS1 ;
I '$D(^PS(55,DFN,"IV",+ON,9)) W !!,$C(7),$C(7),"No labels have been dispensed for this order." N DIR S DIR(0)="E" D ^DIR Q
I $P(^PS(55,DFN,"IV",+ON,2),U,2)'=PSIVSN W !!,"WARNING ",$C(7),$C(7),$C(7),"This order is in a different IV room",!," from the one in which you are entering returned/destroyed!" S E1=$P(^(2),U,2),E=PSIVSN
D PAUSE^VALM1
S PSIVLBTP=2,PSJMORE=0,RDFLAG="ON" D EN^VALM("PSJ LM IV RETURN LABELS")
Q
;
;S RDFLAG="ON",X="Was this bottle RECYCLED or DESTROYED or CANCELLED ?^R^^RECYCLED,DESTROYED,CANCELLED" D ENQ^PSIV Q:X=U I X["?" S HELP="RTDS" D ^PSIVHLP1 G PROCESS1
;W ! S Y=$E(X),PSIVC=$S(Y="R":2,Y="D":3,1:4)
;
WARD ;Get the ward to associate returns or destroyed with.
I '$D(PSJIDLST) W !,"No labels are available" D PAUSE^VALM1 Q
K DIC I $D(^DPT(DFN,.1)) S DIC("B")=^DPT(DFN,.1)
S DIC("A")="Enter ward or ^OUTPATIENT: ",DIC(0)="AEQ",DIC=42,D="B" D IX^DIC G:X="^"!(X="") KILL I $P("^OUTPATIENT",X)="" W $P("^OUTPATIENT",X,2) S RDWARD=.5 G WARD1
S:Y>0 RDWARD=+Y I Y<0 G WARD
;
WARD1 ;
NEW PSIVCTD S PSIVCTD=""
S PSJY=$$PROMPT^PSIVLBRP()
Q:PSJY=""
S PSIVNOL=0
F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" S PSIVNOL=PSIVNOL+1
F PSJSEL=1:1 S PSJSEL1=$P(PSJY,",",PSJSEL) Q:PSJSEL1="" D
. S PSJID=$G(PSJIDLST(PSJSEL1)) Q:PSJID=""
. S PSJIDNO=$P(PSJID,"V",2) D NOW^%DTC
. K DA,DR,DIE,DIC
. S DA=PSJIDNO,DA(1)=DFN,DIE="^PS(55,"_DA(1)_",""IVBCMA"","
. S DR="4////"_%_";5////"_$S(PSIVC=2:"RC",PSIVC=3:"DT",1:"CA")_";9////"_% D ^DIE
. K DA,DR,DIE,DIC
S LABELS=PSIVNOL,ACTION=$S(PSIVC=2:2,PSIVC=3:3,1:4) D ^PSIVLTR,^PSIVSTAT W "...Done."
Q
NRD ;Ask number of bottles/bags
Q
;NO LONGER USE
S MXMN=$P(^PS(55,DFN,"IV",+ON,9),U,3)
NRD1 ;
Q
;NO LONGER USE
R !,"Number of bottles: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X KILL I X?1."?" S HELP="REDT" D ^PSIVHLP G NRD1
I $S($E(X,$E(X)="-"+1,$L(X))'?1.N:1,X<-50:1,X>MXMN:1,1:'X) W $C(7)," ??" G NRD1
;
S PSIVNOL=+X,LABELS=PSIVNOL,ACTION=$S(PSIVC=2:2,PSIVC=3:3,1:4) D ^PSIVLTR,^PSIVSTAT W "...Done."
;
KILL ;
Q
;NO LONGER USE
W:"^"[X $C(7),"NO ACTION TAKEN" K D,LABELS,MXMN,X,Y,PSIVNOL,HELP,DIC,RDFLAG,PSIVC
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVRD 4860 printed Sep 23, 2025@19:41:02 Page 2
PSIVRD ;BIR/PR,MLM-HANDLE QUICK RET/DES ENTRY ;29 SEP 97 / 11:17 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**38,58,88,279,407**;16 DEC 97;Build 26
+2 ; ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ;
EN ; Entry point to enter returns/destroyed items.
+1 ;P407 Added DONE
DO ^PSIVXU
if $DATA(XQUIT)!($GET(DONE))
QUIT
FOR
DO ENGETP^PSIV
if DFN<0
QUIT
DO EN1
Q KILL ACTION,D,DFN,DIC,DIR,DRG,DRGI,DRGN,E,E1,HELP,I,I1,JJ,LABELS,MXMN,ON,ON55,ONCNT,P,PS,PSGDT,PSGID,PSGP,PSGLMT,PSGODDD,PSIVAC,PSIVC,PSIVNOL,PSIVNOW,PSIVON
+1 KILL PSIVPL,PSIVPR,PSIVSITE,PSIVUP,PSIVX,PSJORIFN,PSJORL,PSJHT,PSJPWT,PSJSYSL,PSJSYSU,PSJSYSW,PSJSYSW0,Q,UL80,VA,VADM,VAIN,VAERR,PSIVNU,PSIVOV1,PSIVOV2,PSIVSN,RDFLAG,RDWARD,X,XQUIT,Y
+2 QUIT
+3 ;
EN1 ;
+1 SET PSIVBR="D PROCESS^PSIVRD"
DO ENCHS1^PSIV
+2 QUIT
EN1OLD ;
+1 ;S PSIVAC="RD" D ENNB^PSIVACT I P("PT")'="N" D GTORDRS Q
ORDNO ;
+1 FOR
READ !!,"Enter the order number(s) to be processed: ",PSIVNU:DTIME
if "^"[PSIVNU
QUIT
DO READ
+2 QUIT
+3 ;
READ ; Read order no.s, no profile.
+1 NEW DONE
IF '$TEST!(PSIVNU="^")!(PSIVNU="")
SET PSIVNU=""
QUIT
+2 IF PSIVNU["?"
WRITE !!,"Enter order number(s) separated by a comma e.g. 2,4,5,6.",!
QUIT
+3 IF PSIVNU[" "
WRITE $CHAR(7),$CHAR(7),"??",!!
QUIT
+4 FOR I=1:1:$LENGTH(PSIVNU,",")
SET ON=$PIECE(PSIVNU,",",I)
Begin DoDot:1
+5 IF $LENGTH(ON)'>0
WRITE $CHAR(7),$CHAR(7),"??",!!
SET DONE=1
+6 FOR JJ=1:1:$LENGTH(ON)
if $GET(DONE)
QUIT
IF $ASCII($EXTRACT(ON,JJ))<48!($ASCII($EXTRACT(ON,JJ))>57)
WRITE !!,$CHAR(7),$CHAR(7),"Order ",ON," is invalid.",!!
SET DONE=1
End DoDot:1
+7 IF '$GET(DONE)
FOR I=1:1:$LENGTH(PSIVNU,",")
SET ON=$PIECE(PSIVNU,",",I)
IF '$DATA(^PS(55,DFN,"IV",+ON,0))
WRITE !!,$CHAR(7),$CHAR(7),"Order number ",+ON," does not exist for this patient.",!
SET DONE=1
+8 IF '$GET(DONE)
DO NOW^%DTC
SET PSIVNOW=%
FOR ONCNT=1:1:$LENGTH(PSIVNU,",")
Begin DoDot:1
+9 SET X=$GET(^PS(55,DFN,"IV",+ON,0))
IF $PIECE(X,U,3)<PSIVNOW
IF ("AR"[$PIECE(X,U,17))
SET $PIECE(^PS(55,DFN,"IV",+ON,0),U,17)="E"
DO EXPIR^PSIVOE
End DoDot:1
SET ON=9999999999-$PIECE(PSIVNU,",",ONCNT)
DO OV1
+10 QUIT
+11 ;**********************************************************
+12 ;* GTORDRS, ASK, OV subroutines are no longer use in 5.0. *
+13 ;**********************************************************
GTORDRS ;Needs PSIVBR (Branch point)
+1 SET IOP="HOME"
DO ^%ZIS
KILL %ZIS,IOP
if P("PT")="N"
QUIT
+2 DO ^PSIVPRO
if X="^"
QUIT
IF X]""
GOTO OV
ASK if PS<1
QUIT
WRITE !!,"Choose 1-",PS,": "
READ X:DTIME
if '$TEST
SET X="^"
if "^"[X
QUIT
+1 IF X?1."?"
SET HELP="CHSE"
DO ^PSIVHLP
if X?2."?"
DO H2^PSGON
GOTO ASK
+2 SET PSGLMT=PS
DO ^PSGON
if '$DATA(X)
GOTO ASK
OV ;
+1 WRITE !
FOR PSIVOV1=1:1:PSGODDD
FOR PSIVOV2=1:1:$LENGTH(PSGODDD(PSIVOV1),",")-1
SET ON=+$PIECE(PSGODDD(PSIVOV1),",",PSIVOV2)
SET ON=$SELECT($DATA(^TMP("PSIV",$JOB,"AB",ON)):^(ON),$DATA(^TMP("PSIV",$JOB,"NB",ON)):^(ON),$DATA(^TMP("PSIV",$JOB,"XB",ON)):^(ON),1:"")
if 'ON
QUIT
DO OV1
+2 QUIT
OV1 ;
+1 SET (ON,ON55,P("PON"))=9999999999-ON_"V"
KILL PSIVNUM
DO GT55^PSIVORFB
DO ENNONUM^PSIVORV2(DFN,ON)
+2 DO PROCESS1
+3 QUIT
+4 ;
PROCESS ;
+1 DO FULL^VALM1
+2 SET PSJORD=ON
DO ENNH^PSIVORV2(ON)
PROCESS1 ;
+1 IF '$DATA(^PS(55,DFN,"IV",+ON,9))
WRITE !!,$CHAR(7),$CHAR(7),"No labels have been dispensed for this order."
NEW DIR
SET DIR(0)="E"
DO ^DIR
QUIT
+2 IF $PIECE(^PS(55,DFN,"IV",+ON,2),U,2)'=PSIVSN
WRITE !!,"WARNING ",$CHAR(7),$CHAR(7),$CHAR(7),"This order is in a different IV room",!," from the one in which you are entering returned/destroyed!"
SET E1=$PIECE(^(2),U,2)
SET E=PSIVSN
+3 DO PAUSE^VALM1
+4 SET PSIVLBTP=2
SET PSJMORE=0
SET RDFLAG="ON"
DO EN^VALM("PSJ LM IV RETURN LABELS")
+5 QUIT
+6 ;
+7 ;S RDFLAG="ON",X="Was this bottle RECYCLED or DESTROYED or CANCELLED ?^R^^RECYCLED,DESTROYED,CANCELLED" D ENQ^PSIV Q:X=U I X["?" S HELP="RTDS" D ^PSIVHLP1 G PROCESS1
+8 ;W ! S Y=$E(X),PSIVC=$S(Y="R":2,Y="D":3,1:4)
+9 ;
WARD ;Get the ward to associate returns or destroyed with.
+1 IF '$DATA(PSJIDLST)
WRITE !,"No labels are available"
DO PAUSE^VALM1
QUIT
+2 KILL DIC
IF $DATA(^DPT(DFN,.1))
SET DIC("B")=^DPT(DFN,.1)
+3 SET DIC("A")="Enter ward or ^OUTPATIENT: "
SET DIC(0)="AEQ"
SET DIC=42
SET D="B"
DO IX^DIC
if X="^"!(X="")
GOTO KILL
IF $PIECE("^OUTPATIENT",X)=""
WRITE $PIECE("^OUTPATIENT",X,2)
SET RDWARD=.5
GOTO WARD1
+4 if Y>0
SET RDWARD=+Y
IF Y<0
GOTO WARD
+5 ;
WARD1 ;
+1 NEW PSIVCTD
SET PSIVCTD=""
+2 SET PSJY=$$PROMPT^PSIVLBRP()
+3 if PSJY=""
QUIT
+4 SET PSIVNOL=0
+5 FOR PSJSEL=1:1
SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)
if PSJSEL1=""
QUIT
SET PSIVNOL=PSIVNOL+1
+6 FOR PSJSEL=1:1
SET PSJSEL1=$PIECE(PSJY,",",PSJSEL)
if PSJSEL1=""
QUIT
Begin DoDot:1
+7 SET PSJID=$GET(PSJIDLST(PSJSEL1))
if PSJID=""
QUIT
+8 SET PSJIDNO=$PIECE(PSJID,"V",2)
DO NOW^%DTC
+9 KILL DA,DR,DIE,DIC
+10 SET DA=PSJIDNO
SET DA(1)=DFN
SET DIE="^PS(55,"_DA(1)_",""IVBCMA"","
+11 SET DR="4////"_%_";5////"_$SELECT(PSIVC=2:"RC",PSIVC=3:"DT",1:"CA")_";9////"_%
DO ^DIE
+12 KILL DA,DR,DIE,DIC
End DoDot:1
+13 SET LABELS=PSIVNOL
SET ACTION=$SELECT(PSIVC=2:2,PSIVC=3:3,1:4)
DO ^PSIVLTR
DO ^PSIVSTAT
WRITE "...Done."
+14 QUIT
NRD ;Ask number of bottles/bags
+1 QUIT
+2 ;NO LONGER USE
+3 SET MXMN=$PIECE(^PS(55,DFN,"IV",+ON,9),U,3)
NRD1 ;
+1 QUIT
+2 ;NO LONGER USE
+3 READ !,"Number of bottles: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO KILL
IF X?1."?"
SET HELP="REDT"
DO ^PSIVHLP
GOTO NRD1
+4 IF $SELECT($EXTRACT(X,$EXTRACT(X)="-"+1,$LENGTH(X))'?1.N:1,X<-50:1,X>MXMN:1,1:'X)
WRITE $CHAR(7)," ??"
GOTO NRD1
+5 ;
+6 SET PSIVNOL=+X
SET LABELS=PSIVNOL
SET ACTION=$SELECT(PSIVC=2:2,PSIVC=3:3,1:4)
DO ^PSIVLTR
DO ^PSIVSTAT
WRITE "...Done."
+7 ;
KILL ;
+1 QUIT
+2 ;NO LONGER USE
+3 if "^"[X
WRITE $CHAR(7),"NO ACTION TAKEN"
KILL D,LABELS,MXMN,X,Y,PSIVNOL,HELP,DIC,RDFLAG,PSIVC
+4 SET VALMBCK="R"
+5 QUIT
