PSGMMAR5 ;BIR/CML3-MD MARS - GATHER INFO FOR ACK ORDERS ;14 Oct 98 / 4:29 PM
;;5.0; INPATIENT MEDICATIONS ;**15,20,111,145**;16 DEC 97;Build 17
;
PEND ;*** Only select orders that were acknowledged by nurses and
;*** still having pending status.
;The next 4 lines are looking only at ward parameters. If there is an inpatient with pending orders, the orders will print on the MAR.
NEW PSJSYSW,PSJSYSW0
S PSJSYSW=$O(^PS(59.6,"B",+$G(PSJPWD),0))
S:PSJSYSW PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
Q:'+$P($G(PSJSYSW0),U,6) ;Quit if the order is not pending.
;
NEW ND,ON,TYPE,QST
F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON D
. S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4)
. I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="OZ"_$S($P(ND,U,4)="F":"V",1:"A")
. E S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A")
. I PSGMTYPE[1 D:TYPE'="F" SETTMP D:TYPE="F" IV
. I PSGMTYPE'[1 D
.. I PSGMTYPE[2,(TYPE="U") D SETTMP Q
.. I PSGMTYPE'[2,(TYPE="I") D SETTMP Q
.. I PSGMTYPE[4,(TYPE="F") D IV
Q
;
SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs.
;*** OZ_(V/A) = PRN/One time orders (V=IV).
;*** CZ_(V/A) = Continuous orders (A=U/D).
I PSGMARS=2,(QST["CZ") Q
I PSGMARS=1,(QST["OZ") Q
NEW MARX
D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_+ON_"P"
N PSGMARWC,A ;DEM 04/19/2006 - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
S PSGMARWC=PSGMARWN
S A=$G(^PS(53.1,+ON,"DSS")) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
. N X
. D:$G(PSGMAR24) SPN^PSGMAR0 D:'$G(PSGMAR24) SPN^PSGMMAR0
. Q
I (PSGSS="P")!(PSGSS="C")!(PSGSS="L") S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)="" S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC Q
S ^TMP($J,TM,PSGMARWN,SUB1,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=""
;
;DAM 5-01-07 add XTMP global for printing when PSGSS is not "P", "C", or "L". This reverses PSGMARWN (ward) and SUB1 (patient) so printing will occur with all locations (ward and clinic) appearing together under the patient's name
S ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=""
;
S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC Q
Q
;
IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON)
S X=$P(P("MR"),U,2)
S QST=QST_4
N PSGMARWC ;DEM 04/19/2006 - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
S PSGMARWC=PSGMARWN
I $G(DRG) S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_+ON_"P" D
. N A
. S A=$G(^PS(53.1,+ON,"DSS")) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
. . N X
. . D:$G(PSGMAR24) SPN^PSGMAR0 D:'$G(PSGMAR24) SPN^PSGMMAR0
. . Q
. I PSGSS="P"!(PSGSS="C")!(PSGSS="L") S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q
. S:PSGRBPPN="R" ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. S:PSGRBPPN="P" ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" ;DAM 5-01-07 set ^XTMP global when sorting by patient
. Q
S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMAR5 3373 printed Oct 16, 2024@18:02:26 Page 2
PSGMMAR5 ;BIR/CML3-MD MARS - GATHER INFO FOR ACK ORDERS ;14 Oct 98 / 4:29 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**15,20,111,145**;16 DEC 97;Build 17
+2 ;
PEND ;*** Only select orders that were acknowledged by nurses and
+1 ;*** still having pending status.
+2 ;The next 4 lines are looking only at ward parameters. If there is an inpatient with pending orders, the orders will print on the MAR.
+3 NEW PSJSYSW,PSJSYSW0
+4 SET PSJSYSW=$ORDER(^PS(59.6,"B",+$GET(PSJPWD),0))
+5 if PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+6 ;Quit if the order is not pending.
if '+$PIECE($GET(PSJSYSW0),U,6)
QUIT
+7 ;
+8 NEW ND,ON,TYPE,QST
+9 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AV",PSGP,ON))
if 'ON
QUIT
Begin DoDot:1
+10 SET ND=$GET(^PS(53.1,ON,0))
SET TYPE=$PIECE(ND,U,4)
+11 IF $PIECE(ND,U,7)="P"!($PIECE($GET(^PS(53.1,ON,2)),U)["PRN")
SET QST="OZ"_$SELECT($PIECE(ND,U,4)="F":"V",1:"A")
+12 IF '$TEST
SET QST="CZ"_$SELECT($PIECE(ND,U,4)="F":"V",1:"A")
+13 IF PSGMTYPE[1
if TYPE'="F"
DO SETTMP
if TYPE="F"
DO IV
+14 IF PSGMTYPE'[1
Begin DoDot:2
+15 IF PSGMTYPE[2
IF (TYPE="U")
DO SETTMP
QUIT
+16 IF PSGMTYPE'[2
IF (TYPE="I")
DO SETTMP
QUIT
+17 IF PSGMTYPE[4
IF (TYPE="F")
DO IV
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs.
+1 ;*** OZ_(V/A) = PRN/One time orders (V=IV).
+2 ;*** CZ_(V/A) = Continuous orders (A=U/D).
+3 IF PSGMARS=2
IF (QST["CZ")
QUIT
+4 IF PSGMARS=1
IF (QST["OZ")
QUIT
+5 NEW MARX
+6 DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1)
SET DRG=MARX(1)_U_+ON_"P"
+7 ;DEM 04/19/2006 - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
NEW PSGMARWC,A
+8 SET PSGMARWC=PSGMARWN
+9 SET A=$GET(^PS(53.1,+ON,"DSS"))
IF $PIECE(A,"^")]""
SET PSGMARWN="C!"_$PIECE(A,"^")
IF $GET(SUB1)]""
IF $GET(SUB2)]""
IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
Begin DoDot:1
+10 NEW X
+11 if $GET(PSGMAR24)
DO SPN^PSGMAR0
if '$GET(PSGMAR24)
DO SPN^PSGMMAR0
+12 QUIT
End DoDot:1
+13 IF (PSGSS="P")!(PSGSS="C")!(PSGSS="L")
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=""
if PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
QUIT
+14 SET ^TMP($JOB,TM,PSGMARWN,SUB1,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=""
+15 ;
+16 ;DAM 5-01-07 add XTMP global for printing when PSGSS is not "P", "C", or "L". This reverses PSGMARWN (ward) and SUB1 (patient) so printing will occur with all locations (ward and clinic) appearing together under the patient's name
+17 SET ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=""
+18 ;
+19 if PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
QUIT
+20 QUIT
+21 ;
IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
+1 KILL DRG,P
NEW X,ON55,PSJLABEL
SET DFN=PSGP
SET PSJLABEL=1
DO GT531^PSIVORFA(DFN,ON)
+2 SET X=$PIECE(P("MR"),U,2)
+3 SET QST=QST_4
+4 ;DEM 04/19/2006 - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
NEW PSGMARWC
+5 SET PSGMARWC=PSGMARWN
+6 IF $GET(DRG)
SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))
SET X=$EXTRACT($PIECE(X,U,2),1,20)_U_+ON_"P"
Begin DoDot:1
+7 NEW A
+8 SET A=$GET(^PS(53.1,+ON,"DSS"))
IF $PIECE(A,"^")]""
SET PSGMARWN="C!"_$PIECE(A,"^")
IF $GET(SUB1)]""
IF $GET(SUB2)]""
IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
Begin DoDot:2
+9 NEW X
+10 if $GET(PSGMAR24)
DO SPN^PSGMAR0
if '$GET(PSGMAR24)
DO SPN^PSGMMAR0
+11 QUIT
End DoDot:2
+12 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+13 if PSGRBPPN="R"
SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
+14 ;DAM 5-01-07 set ^XTMP global when sorting by patient
if PSGRBPPN="P"
SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
+15 QUIT
End DoDot:1
+16 if PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
+17 QUIT
