PSIVORE1.m

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 ---PSIVORE1   4476     printed  Feb 18, 2025@23:31:03                                                                                                                                                                                                    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