PSIVORE1 ;BIR/RGY,PR,MLM - ACT,NEW ORDER ;Dec 09, 2020@08:26:32
;;5.0;INPATIENT MEDICATIONS;**58,110,127,133,279,305,319,399**;16 DEC 97;Build 64
;
; Reference to ^PS(55 is supported by DBIA 2191.
;
S ;
Q:+PSJSYSU'=3
D PSBPOIV^PSIVORC1
I $G(PSJCOM) D SETNML55^PSIVORC1
I $G(ON),$G(DFN) N RNDT,OP2 S RNDT=+$$LASTREN^PSJLMPRI(DFN,ON) I RNDT D
.N PSGSA,CD S OD=P(2),CD=P(3) D ENP3^PSIVWL
.N NEXTX,DL,NXTLBL,DAY,LBLPC,BEG,OLDX S NXTLBL=0 S DAY=0,BEG=$P(+PSGSA,".") F LBLPC=1:1:$L(PSGSA," ") S OLDX=$G(NEXTX) S NEXTX=$P(PSGSA," ",LBLPC) D
..S:LBLPC=1 OLDX=NEXTX S:$E($P(NEXTX,".",2),1,2)<$E($P($G(OLDX),".",2),1,2) DAY=DAY+1 S DAY($$FMADD^XLFDT(BEG,DAY)_"."_$P(NEXTX,".",2))=LBLPC
.S D=0 F S D=$O(DAY(D)) Q:'D!$G(NXTLBL) D
..I D>RNDT S NXTLBL=D
.I $G(NXTLBL) S OP2=P(2) S (OD,P(2))=NXTLBL Q
.S (OD,P(2))=RNDT
;
D NOW^%DTC S Y=% Q:P(4)=""!(P(2)="") S:'$D(OD) OD=$S(P(2)>Y:P(2),1:Y) S PSGCNT=0,PNOW=DT K PSGSA
STR ;
;
K PSI F I=0:0 S I=$O(^PS(59.5,PSIVSN,2,"AC",P(4),I)) Q:'I S PSI("E",+(PNOW_"."_$P(^PS(59.5,+PSIVSN,2,I,0),U,4)))=+(PNOW_"."_$P(^(0),U))_U_I,PSI("S",+(PNOW_"."_$P(^(0),U)))=I
;
EC ;
S PSIVEC=$O(PSI("E",Y)) I PSIVEC="" S X1=PNOW,X2=1 D C^%DTC S PNOW=X G STR
I $O(PSI("S",PSIVEC))="" S X1=$O(PSI("S",0)),X2=1 D C^%DTC S X=$P(X,".") S PSI("S",+(X_"."_$P($O(PSI("S",0)),".",2)))=PSI("S",$O(PSI("S",0)))
I $P(^PS(59.5,+PSIVSN,2,PSI("S",$O(PSI("S",PSIVEC))),0),U,6)=$O(PSI("S",PSIVEC)) S Y=PSIVEC G EC
I PSIVEC'<P(2) S CD=$S(P(3)>PSIVEC:PSIVEC,1:P(3)) S:OD=CD CD=CD+.0001 D ENP3^PSIVWL
P ;*305
S:'$D(PSGSA) PSGSA=""
D FULL^VALM1
W:PSGCNT !!,PSGCNT," Label",$E("s",PSGCNT>1)," needed for dose",$E("s",PSGCNT>1)," due at ...",!!
F Y=1:1 S X=$P(PSGSA," ",Y) S:$E(X)="." X=$$CONVER^PSIVORE2(X,Y) Q:X="" W:PSGCNT $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" "_$E(X#1_"000",2,5)_" : "
W ! D:$P(PSIVSITE,U,8) TL^PSIVORE2 D NOW^%DTC S Y=% S PNOW=Y I $D(^PS(59.5,PSIVSN,3,"AT")) W !!,"Next delivery time is " S X=$O(^PS(59.5,PSIVSN,3,"AT",PNOW#1)) S:X="" X=$O(^(X)) S X=$P(X,".",2)_$E("000",1,5-$L(X)) W X," ***" G B1
ACT ; Prompt and process label action.
B I PSGCNT<1 S:($G(RNDT)&$G(OP2)) P(2)=OP2 G K^PSIVORE2
B1 ;
W ! S X="Action (PB"_$S($P(PSIVSITE,U,2):"S",1:"")_")^"_$S(PSGCNT<1:"B",$G(PSJPRI)="D":"B",$P(PSIVSITE,U,2)&$D(X):"S",1:"P")_"^^PRINT LABELS,BYPASS"_$S($P(PSIVSITE,U,2):",SUSPEND LABELS",1:"")
D ENQ^PSIV S X=$E(X) S:X["?" HELP="ANSWER" D:X["?" ^PSIVHLP G:X["?" B1 I "B^"[X G K^PSIVORE2
I "S"[X,$D(^PS(55,"PSIVSUS",PSIVSN,DFN,ON)) D C^PSIVORE2 W !!,"There ",$S(SNM>1:"are",1:"is")," already ",SNM," LABEL",$E("S",SNM>1)," suspended for this order." K SNM,DAT
SS ;
S PSIVA=X,X="# of labels^"_PSGCNT_"^^^QUX=+QUX&(QUX?1N.N)" D ENQ^PSIV W !!
S PSIVLABN=X I X["?"!(X>99) S X=PSIVA W !,"Enter # labels, less than 100, to act on." G SS
I 'X W " No action taken ***" G B1
I PSIVA="S",$D(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,PNOW)) W $C(7),"NO Labels suspended, Wait 8 seconds and try again." D NOW^%DTC S Y=% S PNOW=Y G B1
S $P(^(0),U,16)=$P(^PS(55,DFN,"IV",+ON,0),U,16)+X,PSIVNOL=+X,PSGCNT=PSGCNT-X,PSIVDOSE=$P(PSGSA," ",1,X),PLAST=$P(PSGSA," "),PLAST="."_$P(PLAST,".",2),PSGSA=$P(PSGSA," ",X+1,999) I PLAST>$P(PSGSA," ") S UP1=1
S P(16)=$P(^PS(55,DFN,"IV",+ON,0),U,16)
I $D(UP1) S:$D(X1)#2 XX1=X1 S:$D(X2)#2 XX2=X2 S X1=$E(PSIVDOSE,1,7),X2=1 D C^%DTC S PSGSA=X_PSGSA S:$D(XX1) X1=XX1 S:$D(XX2) X2=XX2 K XX2,XX1
I '$D(UP1) S PSGSA=$E(PSIVDOSE,1,7)_PSGSA
K UP1 I PSIVA="S" S ^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,PNOW)=PSIVLABN_U_PSIVDOSE_U_P(16),Y=0,P(16)=P(16)+X W " ... ",PSIVLABN," Label",$E("s",PSIVLABN>1)," suspended !" S ACTION=5,PSIVNOL=PSIVLABN,TRACK=4 D ^PSIVLTR,NOW^%DTC S Y=% S PNOW=Y K X G B
S IONOFF="" I PSIVPL=ION S P16=P(16),ACTION=1,TRACK=4 D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) S P(16)=$P(^PS(55,DFN,"IV",+ON,0),U,16) G B
W ! S P16=P(16),P(16)=P(16)+X,ZTDTH=$H,ZTIO=PSIVPL F Y="IONOFF","P16","PSIVDOSE","PSIVSITE","PSIVSN","PSIVNOL","DFN","ON","PSJSYSL","PSJSYSW0","PSJSYSW","PSJSYSP","PSJSYSP0","PSJSYSU" S ZTSAVE(Y)=""
S ZTDESC="PRINT IV LABELS",ZTRTN="DEQ^PSIVORE2" D ^%ZTLOAD G B
GSTRING ; Setup edit "^" string.
S PSIVOK="57^58^59^10^3^25^26^39^1^64^63"_$S($E(P("OT"))="I":"^101",1:"")
S EDIT="57^58^59^10^3^25^26^39^1^"_$S(P("OT")="I":"101^",1:"")_"64^63"
S ($P(PSIVOK,"^",14),$P(EDIT,"^",14))=132 ;*399-IND
;*p319 fields 113/126 added
I $G(P("CLIN")),$G(P("APPT")) S $P(PSIVOK,"^",15,16)="113^126",$P(EDIT,"^",15,16)="113^126"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORE1 4476 printed Dec 13, 2024@02:04:39 Page 2
PSIVORE1 ;BIR/RGY,PR,MLM - ACT,NEW ORDER ;Dec 09, 2020@08:26:32
+1 ;;5.0;INPATIENT MEDICATIONS;**58,110,127,133,279,305,319,399**;16 DEC 97;Build 64
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ;
S ;
+1 if +PSJSYSU'=3
QUIT
+2 DO PSBPOIV^PSIVORC1
+3 IF $GET(PSJCOM)
DO SETNML55^PSIVORC1
+4 IF $GET(ON)
IF $GET(DFN)
NEW RNDT,OP2
SET RNDT=+$$LASTREN^PSJLMPRI(DFN,ON)
IF RNDT
Begin DoDot:1
+5 NEW PSGSA,CD
SET OD=P(2)
SET CD=P(3)
DO ENP3^PSIVWL
+6 NEW NEXTX,DL,NXTLBL,DAY,LBLPC,BEG,OLDX
SET NXTLBL=0
SET DAY=0
SET BEG=$PIECE(+PSGSA,".")
FOR LBLPC=1:1:$LENGTH(PSGSA," ")
SET OLDX=$GET(NEXTX)
SET NEXTX=$PIECE(PSGSA," ",LBLPC)
Begin DoDot:2
+7 if LBLPC=1
SET OLDX=NEXTX
if $EXTRACT($PIECE(NEXTX,".",2),1,2)<$EXTRACT($PIECE($GET(OLDX),".",2),1,2)
SET DAY=DAY+1
SET DAY($$FMADD^XLFDT(BEG,DAY)_"."_$PIECE(NEXTX,".",2))=LBLPC
End DoDot:2
+8 SET D=0
FOR
SET D=$ORDER(DAY(D))
if 'D!$GET(NXTLBL)
QUIT
Begin DoDot:2
+9 IF D>RNDT
SET NXTLBL=D
End DoDot:2
+10 IF $GET(NXTLBL)
SET OP2=P(2)
SET (OD,P(2))=NXTLBL
QUIT
+11 SET (OD,P(2))=RNDT
End DoDot:1
+12 ;
+13 DO NOW^%DTC
SET Y=%
if P(4)=""!(P(2)="")
QUIT
if '$DATA(OD)
SET OD=$SELECT(P(2)>Y:P(2),1:Y)
SET PSGCNT=0
SET PNOW=DT
KILL PSGSA
STR ;
+1 ;
+2 KILL PSI
FOR I=0:0
SET I=$ORDER(^PS(59.5,PSIVSN,2,"AC",P(4),I))
if 'I
QUIT
SET PSI("E",+(PNOW_"."_$PIECE(^PS(59.5,+PSIVSN,2,I,0),U,4)))=+(PNOW_"."_$PIECE(^(0),U))_U_I
SET PSI("S",+(PNOW_"."_$PIECE(^(0),U)))=I
+3 ;
EC ;
+1 SET PSIVEC=$ORDER(PSI("E",Y))
IF PSIVEC=""
SET X1=PNOW
SET X2=1
DO C^%DTC
SET PNOW=X
GOTO STR
+2 IF $ORDER(PSI("S",PSIVEC))=""
SET X1=$ORDER(PSI("S",0))
SET X2=1
DO C^%DTC
SET X=$PIECE(X,".")
SET PSI("S",+(X_"."_$PIECE($ORDER(PSI("S",0)),".",2)))=PSI("S",$ORDER(PSI("S",0)))
+3 IF $PIECE(^PS(59.5,+PSIVSN,2,PSI("S",$ORDER(PSI("S",PSIVEC))),0),U,6)=$ORDER(PSI("S",PSIVEC))
SET Y=PSIVEC
GOTO EC
+4 IF PSIVEC'<P(2)
SET CD=$SELECT(P(3)>PSIVEC:PSIVEC,1:P(3))
if OD=CD
SET CD=CD+.0001
DO ENP3^PSIVWL
P ;*305
+1 if '$DATA(PSGSA)
SET PSGSA=""
+2 DO FULL^VALM1
+3 if PSGCNT
WRITE !!,PSGCNT," Label",$EXTRACT("s",PSGCNT>1)," needed for dose",$EXTRACT("s",PSGCNT>1)," due at ...",!!
+4 FOR Y=1:1
SET X=$PIECE(PSGSA," ",Y)
if $EXTRACT(X)="."
SET X=$$CONVER^PSIVORE2(X,Y)
if X=""
QUIT
if PSGCNT
WRITE $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)_" "_$EXTRACT(X#1_"000",2,5)_" : "
+5 WRITE !
if $PIECE(PSIVSITE,U,8)
DO TL^PSIVORE2
DO NOW^%DTC
SET Y=%
SET PNOW=Y
IF $DATA(^PS(59.5,PSIVSN,3,"AT"))
WRITE !!,"Next delivery time is "
SET X=$ORDER(^PS(59.5,PSIVSN,3,"AT",PNOW#1))
if X=""
SET X=$ORDER(^(X))
SET X=$PIECE(X,".",2)_$EXTRACT("000",1,5-$LENGTH(X))
WRITE X," ***"
GOTO B1
ACT ; Prompt and process label action.
B IF PSGCNT<1
if ($GET(RNDT)&$GET(OP2))
SET P(2)=OP2
GOTO K^PSIVORE2
B1 ;
+1 WRITE !
SET X="Action (PB"_$SELECT($PIECE(PSIVSITE,U,2):"S",1:"")_")^"_$SELECT(PSGCNT<1:"B",$GET(PSJPRI)="D":"B",$PIECE(PSIVSITE,U,2)&$DATA(X):"S",1:"P")_"^^PRINT LABELS,BYPASS"_$SELECT($PIECE(PSIVSITE,U,2):",SUSPEND LABELS",1:"")
+2 DO ENQ^PSIV
SET X=$EXTRACT(X)
if X["?"
SET HELP="ANSWER"
if X["?"
DO ^PSIVHLP
if X["?"
GOTO B1
IF "B^"[X
GOTO K^PSIVORE2
+3 IF "S"[X
IF $DATA(^PS(55,"PSIVSUS",PSIVSN,DFN,ON))
DO C^PSIVORE2
WRITE !!,"There ",$SELECT(SNM>1:"are",1:"is")," already ",SNM," LABEL",$EXTRACT("S",SNM>1)," suspended for this order."
KILL SNM,DAT
SS ;
+1 SET PSIVA=X
SET X="# of labels^"_PSGCNT_"^^^QUX=+QUX&(QUX?1N.N)"
DO ENQ^PSIV
WRITE !!
+2 SET PSIVLABN=X
IF X["?"!(X>99)
SET X=PSIVA
WRITE !,"Enter # labels, less than 100, to act on."
GOTO SS
+3 IF 'X
WRITE " No action taken ***"
GOTO B1
+4 IF PSIVA="S"
IF $DATA(^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,PNOW))
WRITE $CHAR(7),"NO Labels suspended, Wait 8 seconds and try again."
DO NOW^%DTC
SET Y=%
SET PNOW=Y
GOTO B1
+5 SET $PIECE(^(0),U,16)=$PIECE(^PS(55,DFN,"IV",+ON,0),U,16)+X
SET PSIVNOL=+X
SET PSGCNT=PSGCNT-X
SET PSIVDOSE=$PIECE(PSGSA," ",1,X)
SET PLAST=$PIECE(PSGSA," ")
SET PLAST="."_$PIECE(PLAST,".",2)
SET PSGSA=$PIECE(PSGSA," ",X+1,999)
IF PLAST>$PIECE(PSGSA," ")
SET UP1=1
+6 SET P(16)=$PIECE(^PS(55,DFN,"IV",+ON,0),U,16)
+7 IF $DATA(UP1)
if $DATA(X1)#2
SET XX1=X1
if $DATA(X2)#2
SET XX2=X2
SET X1=$EXTRACT(PSIVDOSE,1,7)
SET X2=1
DO C^%DTC
SET PSGSA=X_PSGSA
if $DATA(XX1)
SET X1=XX1
if $DATA(XX2)
SET X2=XX2
KILL XX2,XX1
+8 IF '$DATA(UP1)
SET PSGSA=$EXTRACT(PSIVDOSE,1,7)_PSGSA
+9 KILL UP1
IF PSIVA="S"
SET ^PS(55,"PSIVSUS",PSIVSN,DFN,+ON,PNOW)=PSIVLABN_U_PSIVDOSE_U_P(16)
SET Y=0
SET P(16)=P(16)+X
WRITE " ... ",PSIVLABN," Label",$EXTRACT("s",PSIVLABN>1)," suspended !"
SET ACTION=5
SET PSIVNOL=PSIVLABN
SET TRACK=4
DO ^PSIVLTR
DO NOW^%DTC
SET Y=%
SET PNOW=Y
KILL X
GOTO B
+10 SET IONOFF=""
IF PSIVPL=ION
SET P16=P(16)
SET ACTION=1
SET TRACK=4
DO ^PSIVLTR
if P(4)="H"
DO ^PSIVHYPL
if "APSC"[P(4)
DO ^PSIVLABL
SET P(16)=$PIECE(^PS(55,DFN,"IV",+ON,0),U,16)
GOTO B
+11 WRITE !
SET P16=P(16)
SET P(16)=P(16)+X
SET ZTDTH=$HOROLOG
SET ZTIO=PSIVPL
FOR Y="IONOFF","P16","PSIVDOSE","PSIVSITE","PSIVSN","PSIVNOL","DFN","ON","PSJSYSL","PSJSYSW0","PSJSYSW","PSJSYSP","PSJSYSP0","PSJSYSU"
SET ZTSAVE(Y)=""
+12 SET ZTDESC="PRINT IV LABELS"
SET ZTRTN="DEQ^PSIVORE2"
DO ^%ZTLOAD
GOTO B
GSTRING ; Setup edit "^" string.
+1 SET PSIVOK="57^58^59^10^3^25^26^39^1^64^63"_$SELECT($EXTRACT(P("OT"))="I":"^101",1:"")
+2 SET EDIT="57^58^59^10^3^25^26^39^1^"_$SELECT(P("OT")="I":"101^",1:"")_"64^63"
+3 ;*399-IND
SET ($PIECE(PSIVOK,"^",14),$PIECE(EDIT,"^",14))=132
+4 ;*p319 fields 113/126 added
+5 IF $GET(P("CLIN"))
IF $GET(P("APPT"))
SET $PIECE(PSIVOK,"^",15,16)="113^126"
SET $PIECE(EDIT,"^",15,16)="113^126"
+6 QUIT
