PSIVRP ;BIR/MLM-REPRINT IV LABELS FROM WARD OR MANUFACTURING LIST ;12 JUL 96 / 10:45 AM
;;5.0; INPATIENT MEDICATIONS ;**38,58**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PS(52.6 is supported by DBIA 1231
; Reference to ^PS(52.7 is supported by DBIA 2173
; Reference to ^DIC(42 is supported by DBIA# 10039
;
D ^PSIVXU Q:$D(XQUIT) I '$D(^PS(55,"PSIVWL",PSIVSN)) W $C(7),!!,"THIS OPTION MAY BE USED ONLY AFTER THE WARD LIST HAS BEEN RUN",!! G QUIT^PSIVRP1
K DIR S DIR(0)="DOA^NE",DIR("A")="Reprint labels for DATE: ",DIR("B")="TODAY",DIR("??")="^S HELP=""REPRINT"" D ^PSIVHLP2" D ^DIR K DIR G:Y<1 QUIT^PSIVRP1 K PS D GTMES^PSIVRP1
I '$D(PS) W $C(7),!!,"The Ward list & Scheduled Labels options MUST be run for the chosen date",!,"before you may use this option!!",!! K DIR S DIR(0)="E" D ^DIR K DIR G QUIT^PSIVRP1
SELMAN ;
K PSM S PSCT=0 F I=0:0 S I=$O(^PS(59.5,PSIVSN,2,I)) Q:'I S PSIVDTS=^(I,0),PSIVDT=Y_"."_$P(PSIVDTS,"^")/1,PSIVDT=$P(PSIVDTS,"^",2)_PSIVDT S:$D(PS(PSIVDT)) PSM(I)=PSIVDTS,PS(I)=PSIVDT,PSCT=PSCT+1
W !!,?5,"The manufacturing times which scheduled labels have been run for are: " D P0^PSIVWL1 G:'X QUIT^PSIVRP1 K PSR F J=1:1:$L(X,",") S Y=$P(X,",",J) S:$D(PS(+Y)) PSR(PS(Y))=""
FNDLBLS ;
K PS,DIC S J="LAST",DIC=55,DIC("A")="Select PATIENT on LAST usable label: ",DIC(0)="AEMQ" D GTRANGE G:Y<0 QUIT^PSIVRP1 F X=1:1:$S(LIST="M":7,1:6) S LAST($P(STR,"^",X))=@$P(STR,"^",X)
S J="NEXT",DIC("A")="Select PATIENT on NEXT usable label or RETURN to print to end: " D GTRANGE K DIC G:X="^" QUIT^PSIVRP1 S:'DFN LIST=LAST("LIST") F X=1:1:$S(LIST="M":7,1:6) S NEXT($P(STR,"^",X))=@$P(STR,"^",X)
G:NEXT("DFN")="" SKIP F X=2:1:$L(STR,"^") Q:NEXT($P(STR,"^",X))'=LAST($P(STR,"^",X))
I NEXT($P(STR,"^",X))']LAST($P(STR,"^",X)) W $C(7),!!,"NEXT LABEL MUST FOLLOW LAST LABEL",!! G FNDLBLS
SKIP ;
I PSIVPL=ION D DEQ^PSIVRP1 G QUIT^PSIVRP1
QUE ;
K ZTDTH,ZTSAVE S ZTIO=PSIVPL,ZTRTN="DEQ^PSIVRP1",ZTDESC="Reprint I.V. Labels" F X="LAST(","NEXT(","PSR(","PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","PSJSYSP0","STR" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Queued." D QUIT^PSIVRP1
Q
GTRANGE ;
K NEXT S (LIST,PSIVDT,PSIVT,X1,X2,DFN,ON,WRD)=""
;* D ^DIC Q:'$T!(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
D ^DIC Q:(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
ORDER ;
S:'PRO ON="" S P="Select order number of the "_J_" usable label: " W !!,$E(P,1,44),$S(ON:" or RETURN to continue: ",1:": ") R X:DTIME
G:'$T!(X="^") GTRANGE G:$D(PS("A",+X)) ORDER1 I ON,(X="") D PRO G ORDER
I 'PRO,(X["??") D PRO G ORDER
G:X="" GTRANGE W $C(7),!!,"Enter the ",$E(P,8,44)," for ",VADM(1),",",! W:'PRO """??"" to see a profile of all orders on the ward list for this patient,",! W " or ""^"" to exit",!! G ORDER
ORDER1 ;
W !! S ON=+X,Y=^PS(55,DFN,"IV",ON,0),PSIVT=$S($P(Y,"^",4)'="":$P(Y,"^",4),1:0),PSIVDT=$O(PSR(PSIVT)),WRD=$S($D(^DIC(42,+$P(Y,"^",22),0)):$P(^(0),"^",1),1:"Outpatient IV")
S LIST=$S($D(^PS(55,"PSIVWLM",PSIVSN,PSIVDT)):"M",1:"W")
S STR=$S(LIST="M":"LIST^PSIVT^PSIVDT^X1^X2^DFN^ON",1:"LIST^PSIVT^WRD^PSIVDT^DFN^ON") Q:LIST="W" S FILE="AD",X1=0 D BU S X1=X,FILE="SOL",X2=0 D BU S X2=X G:X1=0!(X2=0) QUIT^PSIVRP1 I PSIVT="A" S XT=X1,X1=X2,X2=XT
Q
BU ;
S D1=0,D1=$O(^PS(55,DFN,"IV",ON,FILE,D1))
I $D(^PS(55,DFN,"IV",ON,FILE,+D1,0)) S PSIVDRG=$P(^(0),"^",1,2),NF=$S(FILE="AD":"zz6",1:"zz7"),X=$S($D(^PS("52."_$E(NF,3),+PSIVDRG,0)):$E($P(^(0),"^",1),1,10),1:NF) S X=X_"^"_$P(PSIVDRG,"^",2)_"^"_$E(NF,3)_";"_+PSIVDRG
Q
GTORDR ;
K PS S WRD="" F X=0:0 S WRD=$O(^PS(55,"PSIVWL",PSIVSN,WRD)) Q:WRD="" S PSIVDT="" F X=0:0 S PSIVDT=$O(PSR(PSIVDT)) Q:PSIVDT="" F ON=0:0 S ON=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVDT,DFN,ON)) Q:ON="" S PS("A",ON)=""
Q
PRO ;
;N PG S (PG,PSJLN,PRO)=1,PSIVST="A" D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON=""!($Y+5>IOSL) S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
D HDR^PSJLMHED(DFN)
N PG,PSIVX2 S PSIVX2=0,(PG,PSJLN,PRO)=1,PSIVST="A"
D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON="" S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
NEW XX F XX=0:0 S XX=$O(^TMP("PSJPRO",$J,XX)) Q:'XX W !,^(XX,0)
S:'ON PRO=""
K ^TMP("PSJPRO",$J)
Q
SETP ;
S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVRP 4607 printed Apr 09, 2024@21:08:56 Page 2
PSIVRP ;BIR/MLM-REPRINT IV LABELS FROM WARD OR MANUFACTURING LIST ;12 JUL 96 / 10:45 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**38,58**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191
+4 ; Reference to ^PS(52.6 is supported by DBIA 1231
+5 ; Reference to ^PS(52.7 is supported by DBIA 2173
+6 ; Reference to ^DIC(42 is supported by DBIA# 10039
+7 ;
+8 DO ^PSIVXU
if $DATA(XQUIT)
QUIT
IF '$DATA(^PS(55,"PSIVWL",PSIVSN))
WRITE $CHAR(7),!!,"THIS OPTION MAY BE USED ONLY AFTER THE WARD LIST HAS BEEN RUN",!!
GOTO QUIT^PSIVRP1
+9 KILL DIR
SET DIR(0)="DOA^NE"
SET DIR("A")="Reprint labels for DATE: "
SET DIR("B")="TODAY"
SET DIR("??")="^S HELP=""REPRINT"" D ^PSIVHLP2"
DO ^DIR
KILL DIR
if Y<1
GOTO QUIT^PSIVRP1
KILL PS
DO GTMES^PSIVRP1
+10 IF '$DATA(PS)
WRITE $CHAR(7),!!,"The Ward list & Scheduled Labels options MUST be run for the chosen date",!,"before you may use this option!!",!!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO QUIT^PSIVRP1
SELMAN ;
+1 KILL PSM
SET PSCT=0
FOR I=0:0
SET I=$ORDER(^PS(59.5,PSIVSN,2,I))
if 'I
QUIT
SET PSIVDTS=^(I,0)
SET PSIVDT=Y_"."_$PIECE(PSIVDTS,"^")/1
SET PSIVDT=$PIECE(PSIVDTS,"^",2)_PSIVDT
if $DATA(PS(PSIVDT))
SET PSM(I)=PSIVDTS
SET PS(I)=PSIVDT
SET PSCT=PSCT+1
+2 WRITE !!,?5,"The manufacturing times which scheduled labels have been run for are: "
DO P0^PSIVWL1
if 'X
GOTO QUIT^PSIVRP1
KILL PSR
FOR J=1:1:$LENGTH(X,",")
SET Y=$PIECE(X,",",J)
if $DATA(PS(+Y))
SET PSR(PS(Y))=""
FNDLBLS ;
+1 KILL PS,DIC
SET J="LAST"
SET DIC=55
SET DIC("A")="Select PATIENT on LAST usable label: "
SET DIC(0)="AEMQ"
DO GTRANGE
if Y<0
GOTO QUIT^PSIVRP1
FOR X=1:1:$SELECT(LIST="M":7,1:6)
SET LAST($PIECE(STR,"^",X))=@$PIECE(STR,"^",X)
+2 SET J="NEXT"
SET DIC("A")="Select PATIENT on NEXT usable label or RETURN to print to end: "
DO GTRANGE
KILL DIC
if X="^"
GOTO QUIT^PSIVRP1
if 'DFN
SET LIST=LAST("LIST")
FOR X=1:1:$SELECT(LIST="M":7,1:6)
SET NEXT($PIECE(STR,"^",X))=@$PIECE(STR,"^",X)
+3 if NEXT("DFN")=""
GOTO SKIP
FOR X=2:1:$LENGTH(STR,"^")
if NEXT($PIECE(STR,"^",X))'=LAST($PIECE(STR,"^",X))
QUIT
+4 IF NEXT($PIECE(STR,"^",X))']LAST($PIECE(STR,"^",X))
WRITE $CHAR(7),!!,"NEXT LABEL MUST FOLLOW LAST LABEL",!!
GOTO FNDLBLS
SKIP ;
+1 IF PSIVPL=ION
DO DEQ^PSIVRP1
GOTO QUIT^PSIVRP1
QUE ;
+1 KILL ZTDTH,ZTSAVE
SET ZTIO=PSIVPL
SET ZTRTN="DEQ^PSIVRP1"
SET ZTDESC="Reprint I.V. Labels"
FOR X="LAST(","NEXT(","PSR(","PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","PSJSYSP0","STR"
SET ZTSAVE(X)=""
+2 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
DO QUIT^PSIVRP1
+3 QUIT
GTRANGE ;
+1 KILL NEXT
SET (LIST,PSIVDT,PSIVT,X1,X2,DFN,ON,WRD)=""
+2 ;* D ^DIC Q:'$T!(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
+3 DO ^DIC
if (Y<0)
QUIT
SET DFN=+Y
DO ENIV^PSJAC
DO GTORDR
SET (PRO,ON)=""
IF '$DATA(PS)
WRITE $CHAR(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",!
GOTO GTRANGE
ORDER ;
+1 if 'PRO
SET ON=""
SET P="Select order number of the "_J_" usable label: "
WRITE !!,$EXTRACT(P,1,44),$SELECT(ON:" or RETURN to continue: ",1:": ")
READ X:DTIME
+2 if '$TEST!(X="^")
GOTO GTRANGE
if $DATA(PS("A",+X))
GOTO ORDER1
IF ON
IF (X="")
DO PRO
GOTO ORDER
+3 IF 'PRO
IF (X["??")
DO PRO
GOTO ORDER
+4 if X=""
GOTO GTRANGE
WRITE $CHAR(7),!!,"Enter the ",$EXTRACT(P,8,44)," for ",VADM(1),",",!
if 'PRO
WRITE """??"" to see a profile of all orders on the ward list for this patient,",!
WRITE " or ""^"" to exit",!!
GOTO ORDER
ORDER1 ;
+1 WRITE !!
SET ON=+X
SET Y=^PS(55,DFN,"IV",ON,0)
SET PSIVT=$SELECT($PIECE(Y,"^",4)'="":$PIECE(Y,"^",4),1:0)
SET PSIVDT=$ORDER(PSR(PSIVT))
SET WRD=$SELECT($DATA(^DIC(42,+$PIECE(Y,"^",22),0)):$PIECE(^(0),"^",1),1:"Outpatient IV")
+2 SET LIST=$SELECT($DATA(^PS(55,"PSIVWLM",PSIVSN,PSIVDT)):"M",1:"W")
+3 SET STR=$SELECT(LIST="M":"LIST^PSIVT^PSIVDT^X1^X2^DFN^ON",1:"LIST^PSIVT^WRD^PSIVDT^DFN^ON")
if LIST="W"
QUIT
SET FILE="AD"
SET X1=0
DO BU
SET X1=X
SET FILE="SOL"
SET X2=0
DO BU
SET X2=X
if X1=0!(X2=0)
GOTO QUIT^PSIVRP1
IF PSIVT="A"
SET XT=X1
SET X1=X2
SET X2=XT
+4 QUIT
BU ;
+1 SET D1=0
SET D1=$ORDER(^PS(55,DFN,"IV",ON,FILE,D1))
+2 IF $DATA(^PS(55,DFN,"IV",ON,FILE,+D1,0))
SET PSIVDRG=$PIECE(^(0),"^",1,2)
SET NF=$SELECT(FILE="AD":"zz6",1:"zz7")
SET X=$SELECT($DATA(^PS("52."_$EXTRACT(NF,3),+PSIVDRG,0)):$EXTRACT($PIECE(^(0),"^",1),1,10),1:NF)
SET X=X_"^"_$PIECE(PSIVDRG,"^",2)_"^"_$EXTRACT(NF,3)_";"_+PSIVDRG
+3 QUIT
GTORDR ;
+1 KILL PS
SET WRD=""
FOR X=0:0
SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD))
if WRD=""
QUIT
SET PSIVDT=""
FOR X=0:0
SET PSIVDT=$ORDER(PSR(PSIVDT))
if PSIVDT=""
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVDT,DFN,ON))
if ON=""
QUIT
SET PS("A",ON)=""
+2 QUIT
PRO ;
+1 ;N PG S (PG,PSJLN,PRO)=1,PSIVST="A" D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON=""!($Y+5>IOSL) S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
+2 DO HDR^PSJLMHED(DFN)
+3 NEW PG,PSIVX2
SET PSIVX2=0
SET (PG,PSJLN,PRO)=1
SET PSIVST="A"
+4 DO HDL^PSIVPRO
FOR X1=1:1
SET ON=$ORDER(PS("A",ON))
if ON=""
QUIT
SET ON55=ON
DO GT55^PSIVORFB
SET ON=9999999999-ON
SET PSIVX1=ON55
DO ENPL^PSIVPRO
SET ON=9999999999-ON
+5 NEW XX
FOR XX=0:0
SET XX=$ORDER(^TMP("PSJPRO",$JOB,XX))
if 'XX
QUIT
WRITE !,^(XX,0)
+6 if 'ON
SET PRO=""
+7 KILL ^TMP("PSJPRO",$JOB)
+8 QUIT
SETP ;
+1 SET Y=^PS(55,DFN,"IV",ON,0)
FOR X=1:1:23
SET P(X)=$PIECE(Y,"^",X)
+2 QUIT
