PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm
;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9
;
PEND ;*** Only select orders that were acknowledged by nurses and are
;*** still having pending status.
NEW X S X=$O(^PS(59.6,"B",+PSJPWD,0)) Q:'+$P($G(^PS(59.6,+X,0)),U,6)
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)
. S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4)
. I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$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.
;*** PZ_(V/A) = PRN/One time orders (V=IV).
;*** CZ_(V/A) = Continuous orders (A=U/D).
I 'PSJMPRN,(QST["PZ") Q
NEW MARX
D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON
;*** Set up ^TMP for sort by patients
S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCHE=$P($G(^PS(53.1,ON,2)),U)
S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999")
D SI
I PSGSS="P" D Q
. S ^TMP($J,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
. S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD
. S ^TMP($J,QST,PSGP,ON,1)=PSJSI
;*** Set up ^TMP when listing by ward
S:PSGRBADM="A" ^TMP($J,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
S ^TMP($J,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
S ^TMP($J,QST,PSGP,ON,1)=PSJSI
Q
SI ;*** Find the Special instructions.
S X=0,PSJSI="" F S X=$O(^PS(53.1,ON,12,X)) Q:'X S Z=$G(^(X,0)),Y=$L(PSJSI) S:Y+$L(Z)'>179 PSJSI=PSJSI_Z_" " I Y+$L(Z)>179 S PSJSI="SEE PROVIDER COMMENTS" Q
Q
;
IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
K DRG,P NEW X,ON55,P,PSJLABEL
S DFN=PSGP,PSJLABEL=1 D GT531^PSIVORFA(DFN,ON)
S X=$P(P("MR"),U,2)
S QST=QST_4
S PSJADT=$S(QST["C":"8999999",1:"9999999")
I 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 D
. I PSGSS="P" S ^TMP($J,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB Q
. S:PSGRBADM="A" ^TMP($J,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
. S:PSGRBADM="R" ^TMP($J,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
. S:PSGRBADM="P" ^TMP($J,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJMPEND 2975 printed Apr 09, 2024@21:07:17 Page 2
PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9
+2 ;
PEND ;*** Only select orders that were acknowledged by nurses and are
+1 ;*** still having pending status.
+2 NEW X
SET X=$ORDER(^PS(59.6,"B",+PSJPWD,0))
if '+$PIECE($GET(^PS(59.6,+X,0)),U,6)
QUIT
+3 NEW ND,ON,TYPE,QST
+4 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AV",PSGP,ON))
if 'ON
QUIT
Begin DoDot:1
+5 SET ND=$GET(^PS(53.1,ON,0))
SET TYPE=$PIECE(ND,U,4)
+6 SET ND2=$GET(^PS(53.1,ON,2))
SET PSGLSD=$PIECE(ND2,U,2)
SET PSGLFD=$PIECE(ND2,U,4)
+7 IF $PIECE(ND,U,7)="P"!($PIECE($GET(^PS(53.1,ON,2)),U)["PRN")
SET QST="PZ"_$SELECT($PIECE(ND,U,4)="F":"V",1:"A")
+8 IF '$TEST
SET QST="CZ"_$SELECT($PIECE(ND,U,4)="F":"V",1:"A")
+9 IF PSGMTYPE[1
if TYPE'="F"
DO SETTMP
if TYPE="F"
DO IV
+10 IF PSGMTYPE'[1
Begin DoDot:2
+11 IF PSGMTYPE[2
IF (TYPE="U")
DO SETTMP
QUIT
+12 IF PSGMTYPE'[2
IF (TYPE="I")
DO SETTMP
QUIT
+13 IF PSGMTYPE[4
IF (TYPE="F")
DO IV
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
SETTMP ;*** Setup ^tmp for pending U/D and Inpatient med IVs.
+1 ;*** PZ_(V/A) = PRN/One time orders (V=IV).
+2 ;*** CZ_(V/A) = Continuous orders (A=U/D).
+3 IF 'PSJMPRN
IF (QST["PZ")
QUIT
+4 NEW MARX
+5 DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1)
SET DRG=MARX(1)_U_ON
+6 ;*** Set up ^TMP for sort by patients
+7 SET PSJDOS=$PIECE(^PS(53.1,ON,.2),U,2)
SET PSJMR=$EXTRACT($SELECT($PIECE(ND,U,3)]"":$PIECE(ND,U,3),1:$PIECE(ND,U)),1,5)
SET PSJSCHE=$PIECE($GET(^PS(53.1,ON,2)),U)
+8 SET PSJHOLD=$SELECT($PIECE(ND,U,9)["H":1,1:0)
SET PSGLOD=$PIECE(ND,U,14)
SET PSJATME=9999
SET PSJADT=$SELECT(QST["C":"8999999",1:"9999999")
+9 DO SI
+10 IF PSGSS="P"
Begin DoDot:1
+11 SET ^TMP($JOB,PSJADT,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
+12 SET ^TMP($JOB,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD
+13 SET ^TMP($JOB,QST,PSGP,ON,1)=PSJSI
End DoDot:1
QUIT
+14 ;*** Set up ^TMP when listing by ward
+15 if PSGRBADM="A"
SET ^TMP($JOB,PSJADT,TM,PSJATME,PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+16 if PSGRBADM="R"
SET ^TMP($JOB,PSJADT,TM,PSJPRB,PPN,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+17 if PSGRBADM="P"
SET ^TMP($JOB,PSJADT,TM,PPN_U_PSGP,PSJATME,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+18 SET ^TMP($JOB,QST,PSGP,ON)=PSJDOS_U_PSJMR_U_PSJSCHE_U_PSJHOLD_U_PSGLOD_U_PSGLSD_U_PSGLFD
+19 SET ^TMP($JOB,QST,PSGP,ON,1)=PSJSI
+20 QUIT
SI ;*** Find the Special instructions.
+1 SET X=0
SET PSJSI=""
FOR
SET X=$ORDER(^PS(53.1,ON,12,X))
if 'X
QUIT
SET Z=$GET(^(X,0))
SET Y=$LENGTH(PSJSI)
if Y+$LENGTH(Z)'>179
SET PSJSI=PSJSI_Z_" "
IF Y+$LENGTH(Z)>179
SET PSJSI="SEE PROVIDER COMMENTS"
QUIT
+2 QUIT
+3 ;
IV ;*** Sort IV pending orders for 24 Hrs, 7/14 Day MAR.
+1 KILL DRG,P
NEW X,ON55,P,PSJLABEL
+2 SET DFN=PSGP
SET PSJLABEL=1
DO GT531^PSIVORFA(DFN,ON)
+3 SET X=$PIECE(P("MR"),U,2)
+4 SET QST=QST_4
+5 SET PSJADT=$SELECT(QST["C":"8999999",1:"9999999")
+6 IF 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
Begin DoDot:1
+7 IF PSGSS="P"
SET ^TMP($JOB,PSJADT,PPN_U_PSGP,"9999",QST,X)=PSGP_U_ON_U_PSJPPID_U_PSJPWDN_U_PSJPRB
QUIT
+8 if PSGRBADM="A"
SET ^TMP($JOB,PSJADT,TM,"9999",PSJPRB,PPN,QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+9 if PSGRBADM="R"
SET ^TMP($JOB,PSJADT,TM,PSJPRB,PPN,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
+10 if PSGRBADM="P"
SET ^TMP($JOB,PSJADT,TM,PPN_U_PSGP,"9999",QST,DRG)=PSGP_U_ON_U_PSJPPID_U_PSGWN_U_PSJPRB
End DoDot:1
+11 QUIT
