PSGMAR0 ;BIR/CML3-GATHERS INFO FOR 24 HOUR MAR ;29-May-2012 14:28;PLS
;;5.0; INPATIENT MEDICATIONS ;**8,15,20,1013,111,145,196,1015**;16 DEC 97;Build 62
;
; Reference to ^PS(55 supported by DBIA #2191.
; Reference to ^PS(59.7 supported by DBIA #2181.
; Reference to CUR^FHORD7 supported by DBIA #2019.
;
; Modified - IHS/MSC/PLS - 11/11/2011 - Line ORSET+3
S PSGMSORT=$P($G(^PS(59.7,1,26)),U,4)
K ^TMP($J) D NOW^%DTC S PSGDT=%,PSGMARWN="",PSJACNWP=1 D @("G"_PSGSS) I $D(^TMP($J))<10 U IO W:$Y @IOF W !!,"(No data found for 24 hour MAR run.)"
;
;
DONE ;
K PSGMFOR
Q
;
GG ; find individual wards in this ward group
F PSGMARWD=0:0 S PSGMARWD=$O(^PS(57.5,"AC",PSGMARWG,PSGMARWD)) Q:'PSGMARWD D GW
Q
;
GW ; find patients in each ward
I $D(^DIC(42,PSGMARWD,0)),$P(^(0),"^")]"" S PSGMARWN=$P(^(0),"^")
E Q
;
I 'PSGMARWG S PSGMARWG=+$O(^PS(57.5,"AB",PSGMARWD,0))
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGMARWN,PSGP)) Q:'PSGP D PSJAC2^PSJAC(1),DTSET:'$P(PSGMARDT,".",2) D GPI
Q
;
GP ; go thru selected patients
F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP D PSJAC2^PSJAC(1),DTSET:'$P(PSGMARDT,".",2) D GPI
Q
;
GL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D GC
Q
GC S PSGAPWDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
D DTSET:'$P(PSGMARDT,".",2)
;DEM 04/19/2006 - PSGCAD = User selected start date/time minus .0001
S PSGCAD=PSGPLS-.0001
F S PSGCAD=$O(^PS(55,"AIVC",PSGCAD)) Q:PSGCAD="" D ;DEM 04/19/2006 - Index by order stop date/time.
. S PSGP=0
. F S PSGP=$O(^PS(55,"AIVC",PSGCAD,CL,PSGP)) Q:PSGP="" D PSJAC2^PSJAC(1),DTSET:'$P(PSGMARDT,".",2) D GPI ;DEM 04/19/2006 - Removed S PSJPWDN="C!"_CL D GPI. Want to rollup patients non-clinic orders under patients location.
;DEM 04/19/2006 - PSGCAD = User selected start date/time minus .0001
S PSGCAD=PSGPLS-.0001
F S PSGCAD=$O(^PS(55,"AUDC",PSGCAD)) Q:PSGCAD="" D ;DEM 04/19/2006 - Index by order stop date/time.
. S PSGP=0
. F S PSGP=$O(^PS(55,"AUDC",PSGCAD,CL,PSGP)) Q:PSGP="" D PSJAC2^PSJAC(1),DTSET:'$P(PSGMARDT,".",2) D GPI ;DEM 04/19/2006 - Removed S PSJPWDN="C!"_CL D GPI. Want to rollup patients non-clinic orders under patients location.
Q
GPI ; get patient info
; PSGTMALL=1(sort by all team), PSGTM=1(individual team(S) selected).
S TM="" S:PSGSS="P"!(PSGSS="C")!(PSGSS="L") PSGMARWN=$S(PSJPWDN]"":PSJPWDN,1:"NOT FOUND")
S:PSJPRB="" PSJPRB="zz"
S:"GPCL"[PSGSS!('$G(PSGTM)&'$G(PSGTMALL)) TM="zz"
S:$G(TM)="" TM=$S(PSJPRB="zz":0,1:+$O(^PS(57.7,"AWRT",PSGMARWD,PSJPRB,0))),TM=$S('TM:"zz",'$D(^PS(57.7,PSGMARWD,1,TM,0)):TM,$P(^(0),"^")]"":$P(^(0),"^"),1:TM)
Q:'$G(PSGTMALL)&$G(PSGTM)&'$D(PSGTM(TM))
S PPN=$E($P(PSGP(0),"^"),1,15)_"^"_PSGP
N SUB1,SUB2 S:PSGRBPPN="P" SUB1=PPN,SUB2=PSJPRB S:PSGRBPPN="R" SUB1=PSJPRB,SUB2=PPN
I PSGMARB=1 D SPN Q
I PSGMTYPE[1 F XTYPE=2:1:6 D @XTYPE
I PSGMTYPE'[1 F XTYPE=2:1:6 D:PSGMTYPE[XTYPE @XTYPE
N PSGMAR24 ;DEM 04/19/2006 - 24 Hour MAR flag for call to shared routine ^PSGMMAR5 (24 Hour MAR Reports and 7 Day/14 Day MAR Reports both call ^PSGMMAR5).
S PSGMAR24=1
D ^PSGMMAR5
K PSGMAR24
D:$S(PSGSS["P"!(PSGSS="C")!(PSGSS="L"):$D(^TMP($J,PPN)),1:$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2))) SPN
Q
;
2 ;Loop thru UD orders
;DEM 04/19/2006
; Location variable PSGMARWC added to correctly rollup orders
; under location. The location can change if the UD order is
; assoicated with a clinic location. If the location changes
; under the aforementioned scenario, then PSGMARWC preserves
; the original value and is used to restore location to it's
; original value.
;
N PSGMARWC
S PSGMARWC=PSGMARWN ;DEM 04/19/2006 - Preserve original value of patients location. If location is changed, then restore to original value after call to ORSET.
F PST="C","O","OC","P","R" F PSGMARED=PSGPLS-.0001:0 S PSGMARED=$O(^PS(55,PSGP,5,"AU",PST,PSGMARED)) Q:'PSGMARED F PSGMARO=0:0 S PSGMARO=$O(^PS(55,PSGP,5,"AU",PST,PSGMARED,PSGMARO)) Q:'PSGMARO D ORSET S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
S PST="S" D ^PSGMIV
Q
3 ;Loop thru IV orders that are Piggy back and Syringes types.
F PST="P","S" D ^PSGMIV
Q
4 ;Loop thru IV orders(Additives).
S PST="A" D ^PSGMIV
Q
5 ;Loop thru IV orders(Hyperal).
S PST="H" D ^PSGMIV
Q
6 ;Loop thru IV order(Chemo).
S PST="C" D ^PSGMIV
Q
;
; PSGMFOR is set to bypass "fill on request" when call ^PSGPL0.
ORSET ; order record set
S PSGMFOR="",ND2=$G(^PS(55,PSGP,5,PSGMARO,2)),(SD,X)=$P($P(ND2,"^",2),".") Q:X>PSGPLF S FD=$P($P(ND2,"^",4),"."),T=$P(ND2,"^",6)
;
S A=$G(^PS(55,PSGP,5,PSGMARO,8)) I $P(A,"^")]"" S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D SPN
;
NEW MARX D DRGDISP^PSJLMUT1(PSGP,+PSGMARO_"U",20,0,.MARX,1)
;IHS/MSC/MGH patch 1013 uppercase sort for MAR
S DRG=$$UP^XLFSTR(MARX(1))_U_PSGMARO_"U",QST=$S(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",$P(ND2,"^")["PRN":"OR",1:"CR")
S X="" I "OB"]QST,$P(ND2,U)'["@",$P(ND2,U,2)'>PSGPLS,$P(ND2,U,4)'<PSGPLF,$P(ND2,U,5),$P(ND2,U,6)<1441,$P(ND2,U,6)'="D" S X=$P(ND2,U,5),PSGPLC=1
E I "OB"]QST S PSGPLO=PSGMARO K PSGMAR D ^PSGPL0 S (Q,X)="" F QX=0:0 S Q=$O(PSGMAR(Q)) Q:Q="" S X=X_$E("0",2-$L(Q))_Q_"-"
S X=$S(QST["C"!(QST["O"):$P(ND2,"^",5),1:"")_"^"_X
;
;DAM 5-01-07 Add next line to include non-IV meds when printing by PATIENT and choosing to print "ALL MEDS"
I PSGSS="P" S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=X Q
;
;DAM 5-01-07 Add check to see if user wants to include ward orders when printing by CLINIC GROUP
I PSGSS="L" Q:((PSGINWDG="")&(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=X Q
;
;DAM 5-01-07 Add check to see if user wants to include ward orders when printing by CLINIC
I PSGSS="C" Q:((PSGINWD="")&(PSGMARWN'["C!")) I ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!")) D Q
. S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=X
Q:(PSGSS="L")!(PSGSS="C")
;
; DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by WARD GROUP
I PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) S ^TMP($J,TM,PSGMARWN,SUB1,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=X
;
;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by WARD.
I (PSGSS="W") Q:((PSGINCL="")&(PSGMARWN["C!")) S ^TMP($J,TM,PSGMARWN,SUB1,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=X
;
;DAM 5-01-07 Add an XTMP global to swap location and patient name in the subscripts when printing MAR by WARD/PATIENT or WARD GROUP.
N PSGDEM S PSGDEM=X ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
S PSGREP="PSGM_"_$J
S X1=DT,X2=1 D C^%DTC K %,%H,%T
S ^XTMP(PSGREP,0)=X_U_DT
I PSGRBPPN="P",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD
. S ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=PSGDEM
I PSGRBPPN="P",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD GROUP
. S ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$S(+PSGMSORT:$E(QST,1),1:QST),DRG)=PSGDEM
S X=PSGDEM ;transfer contents of patient drug information contained in PSGDEM back to X
;End DAM modifications 5-01-07
Q
;
SPN ; set patient node
D DIET
S X=$P(PSGP(0),U)_U_$E($P(PSJPDOB,U,2),1,10)_";"_PSJPAGE_U_VA("PID")_U_PSJPDX_U_PSJPWT_U_PSJPWTD_U_PSJPHT_U_PSJPHTD_U_$P(PSJPAD,U,2)_U_$P(PSJPTD,U,2)_U_$P(PSJPSEX,U,2)_U_PSJPWD_U_PSGPLS_U_PSGPLF_U_PSGMARSD_U_PSGMARFD_U_PSGMARSP_U_PSGMARFP
;GMZ:PSJ*5*196;Set diet info for each patient.
I PSGSS="P"!(PSGSS="C")!(PSGSS="L") S ^TMP($J,PPN)=X_U_PSGMARWN_U_PSJPRB_U_$G(PSJDIET) Q
;
;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by ward.
I PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) S ^TMP($J,TM,PSGMARWN,SUB1,SUB2)=X_U_U_U_$G(PSJDIET)
;
;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by ward group.
I PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) S ^TMP($J,TM,PSGMARWN,SUB1,SUB2)=X_U_U_U_$G(PSJDIET)
;
;DAM 5-01-07 Add an XTMP global to reverse location and patient name in the subscripts when printing MAR by WARD/PATIENT or WARD GROUP.
N PSGDEM S PSGDEM=X_U_U_U_$G(PSJDIET) ;transfer contents of patient demographics contained in "X" above to a new variable temporarily
S PSGREP="PSGM_"_$J
S X1=DT,X2=1 D C^%DTC K %,%H,%T
S ^XTMP(PSGREP,0)=X_U_DT
I PSGRBPPN="P",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD
. S ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2)=PSGDEM
I PSGRBPPN="P",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD GROUP
. S ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2)=PSGDEM
S X=PSGDEM ;transfer contents of patient demographics contained in PSGDEM back to X
;End DAM modifications 3-7-07
Q
DIET ; Include abbr. diet label if indicated in the Site par.
NEW ADM,DFN,PSJMPAR K PSJDIET
;MGH Set to null due to undefined error
S Y=""
S PSJMPAR=$G(^PS(59.7,1,26))
Q:'$P(PSJMPAR,U,3)
S DFN=PSGP,ADM=$G(^DPT("CN",PSGMARWN,DFN))
I +ADM D CUR^FHORD7 S PSJDIET=Y
Q
;
DTSET ;
S (PSGPLS,PSGPLF)=PSGMARDT
S PSJSYSW=$O(^PS(59.6,"B",+$G(PSJPWD),0))
S:PSJSYSW PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
I $D(PSJSYSW0),$P(PSJSYSW0,"^",8) S ST=$P(PSJSYSW0,"^",8),FT=$P(PSJSYSW0,"^",9)
E S ST="0001",FT=24
SET S PSGMARSD=$E(ST,1,2),PSGMARFD=$E(FT,1,2) S:'PSGMARSD PSGMARSD="01" S PSGMARFD=$S(+PSGMARSD=1:24,PSGMARSD=PSGMARFD:PSGMARSD-1,1:PSGMARFD) S:$L(PSGMARFD)<2 PSGMARFD=0_PSGMARFD
I ST>1 S X1=$P(PSGPLF,"."),X2=1 D C^%DTC S PSGPLF=X
S PSGPLS=+(PSGPLS_"."_ST),PSGPLF=+(PSGPLF_"."_FT)
S PSGMARSP=$$ENDTC2^PSGMI(PSGPLS),PSGMARFP=$$ENDTC2^PSGMI(PSGPLF)
Q
PSGMAR0 ;BIR/CML3-GATHERS INFO FOR 24 HOUR MAR ;29-May-2012 14:28;PLS
+1 ;;5.0; INPATIENT MEDICATIONS ;**8,15,20,1013,111,145,196,1015**;16 DEC 97;Build 62
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ; Reference to ^PS(59.7 supported by DBIA #2181.
+5 ; Reference to CUR^FHORD7 supported by DBIA #2019.
+6 ;
+7 ; Modified - IHS/MSC/PLS - 11/11/2011 - Line ORSET+3
+8 SET PSGMSORT=$PIECE($GET(^PS(59.7,1,26)),U,4)
+9 KILL ^TMP($JOB)
DO NOW^%DTC
SET PSGDT=%
SET PSGMARWN=""
SET PSJACNWP=1
DO @("G"_PSGSS)
IF $DATA(^TMP($JOB))<10
USE IO
IF $Y
WRITE @IOF
WRITE !!,"(No data found for 24 hour MAR run.)"
+10 ;
+11 ;
DONE ;
+1 KILL PSGMFOR
+2 QUIT
+3 ;
GG ; find individual wards in this ward group
+1 FOR PSGMARWD=0:0
SET PSGMARWD=$ORDER(^PS(57.5,"AC",PSGMARWG,PSGMARWD))
IF 'PSGMARWD
QUIT
DO GW
+2 QUIT
+3 ;
GW ; find patients in each ward
+1 IF $DATA(^DIC(42,PSGMARWD,0))
IF $PIECE(^(0),"^")]""
SET PSGMARWN=$PIECE(^(0),"^")
+2 IF '$TEST
QUIT
+3 ;
+4 IF 'PSGMARWG
SET PSGMARWG=+$ORDER(^PS(57.5,"AB",PSGMARWD,0))
+5 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGMARWN,PSGP))
IF 'PSGP
QUIT
DO PSJAC2^PSJAC(1)
IF '$PIECE(PSGMARDT,".",2)
DO DTSET
DO GPI
+6 QUIT
+7 ;
GP ; go thru selected patients
+1 FOR PSGP=0:0
SET PSGP=$ORDER(PSGPAT(PSGP))
IF 'PSGP
QUIT
DO PSJAC2^PSJAC(1)
IF '$PIECE(PSGMARDT,".",2)
DO DTSET
DO GPI
+2 QUIT
+3 ;
GL SET CL=""
FOR
SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
IF CL=""
QUIT
DO GC
+1 QUIT
GC SET PSGAPWDN=$SELECT($DATA(^SC(CL,0)):$PIECE(^(0),"^"),1:"")
+1 IF '$PIECE(PSGMARDT,".",2)
DO DTSET
+2 ;DEM 04/19/2006 - PSGCAD = User selected start date/time minus .0001
+3 SET PSGCAD=PSGPLS-.0001
+4 ;DEM 04/19/2006 - Index by order stop date/time.
FOR
SET PSGCAD=$ORDER(^PS(55,"AIVC",PSGCAD))
IF PSGCAD=""
QUIT
Begin DoDot:1
+5 SET PSGP=0
+6 ;DEM 04/19/2006 - Removed S PSJPWDN="C!"_CL D GPI. Want to rollup patients non-clinic orders under patients location.
FOR
SET PSGP=$ORDER(^PS(55,"AIVC",PSGCAD,CL,PSGP))
IF PSGP=""
QUIT
DO PSJAC2^PSJAC(1)
IF '$PIECE(PSGMARDT,".",2)
DO DTSET
DO GPI
End DoDot:1
+7 ;DEM 04/19/2006 - PSGCAD = User selected start date/time minus .0001
+8 SET PSGCAD=PSGPLS-.0001
+9 ;DEM 04/19/2006 - Index by order stop date/time.
FOR
SET PSGCAD=$ORDER(^PS(55,"AUDC",PSGCAD))
IF PSGCAD=""
QUIT
Begin DoDot:1
+10 SET PSGP=0
+11 ;DEM 04/19/2006 - Removed S PSJPWDN="C!"_CL D GPI. Want to rollup patients non-clinic orders under patients location.
FOR
SET PSGP=$ORDER(^PS(55,"AUDC",PSGCAD,CL,PSGP))
IF PSGP=""
QUIT
DO PSJAC2^PSJAC(1)
IF '$PIECE(PSGMARDT,".",2)
DO DTSET
DO GPI
End DoDot:1
+12 QUIT
GPI ; get patient info
+1 ; PSGTMALL=1(sort by all team), PSGTM=1(individual team(S) selected).
+2 SET TM=""
IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
SET PSGMARWN=$SELECT(PSJPWDN]"":PSJPWDN,1:"NOT FOUND")
+3 IF PSJPRB=""
SET PSJPRB="zz"
+4 IF "GPCL"[PSGSS!('$GET(PSGTM)&'$GET(PSGTMALL))
SET TM="zz"
+5 IF $GET(TM)=""
SET TM=$SELECT(PSJPRB="zz":0,1:+$ORDER(^PS(57.7,"AWRT",PSGMARWD,PSJPRB,0)))
SET TM=$SELECT('TM:"zz",'$DATA(^PS(57.7,PSGMARWD,1,TM,0)):TM,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:TM)
+6 IF '$GET(PSGTMALL)&$GET(PSGTM)&'$DATA(PSGTM(TM))
QUIT
+7 SET PPN=$EXTRACT($PIECE(PSGP(0),"^"),1,15)_"^"_PSGP
+8 NEW SUB1,SUB2
IF PSGRBPPN="P"
SET SUB1=PPN
SET SUB2=PSJPRB
IF PSGRBPPN="R"
SET SUB1=PSJPRB
SET SUB2=PPN
+9 IF PSGMARB=1
DO SPN
QUIT
+10 IF PSGMTYPE[1
FOR XTYPE=2:1:6
DO @XTYPE
+11 IF PSGMTYPE'[1
FOR XTYPE=2:1:6
IF PSGMTYPE[XTYPE
DO @XTYPE
+12 ;DEM 04/19/2006 - 24 Hour MAR flag for call to shared routine ^PSGMMAR5 (24 Hour MAR Reports and 7 Day/14 Day MAR Reports both call ^PSGMMAR5).
NEW PSGMAR24
+13 SET PSGMAR24=1
+14 DO ^PSGMMAR5
+15 KILL PSGMAR24
+16 IF $SELECT(PSGSS["P"!(PSGSS="C")!(PSGSS="L")
DO SPN
+17 QUIT
+18 ;
2 ;Loop thru UD orders
+1 ;DEM 04/19/2006
+2 ; Location variable PSGMARWC added to correctly rollup orders
+3 ; under location. The location can change if the UD order is
+4 ; assoicated with a clinic location. If the location changes
+5 ; under the aforementioned scenario, then PSGMARWC preserves
+6 ; the original value and is used to restore location to it's
+7 ; original value.
+8 ;
+9 NEW PSGMARWC
+10 ;DEM 04/19/2006 - Preserve original value of patients location. If location is changed, then restore to original value after call to ORSET.
SET PSGMARWC=PSGMARWN
+11 FOR PST="C","O","OC","P","R"
FOR PSGMARED=PSGPLS-.0001:0
SET PSGMARED=$ORDER(^PS(55,PSGP,5,"AU",PST,PSGMARED))
IF 'PSGMARED
QUIT
FOR PSGMARO=0:0
SET PSGMARO=$ORDER(^PS(55,PSGP,5,"AU",PST,PSGMARED,PSGMARO))
IF 'PSGMARO
QUIT
DO ORSET
IF PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
+12 SET PST="S"
DO ^PSGMIV
+13 QUIT
3 ;Loop thru IV orders that are Piggy back and Syringes types.
+1 FOR PST="P","S"
DO ^PSGMIV
+2 QUIT
4 ;Loop thru IV orders(Additives).
+1 SET PST="A"
DO ^PSGMIV
+2 QUIT
5 ;Loop thru IV orders(Hyperal).
+1 SET PST="H"
DO ^PSGMIV
+2 QUIT
6 ;Loop thru IV order(Chemo).
+1 SET PST="C"
DO ^PSGMIV
+2 QUIT
+3 ;
+4 ; PSGMFOR is set to bypass "fill on request" when call ^PSGPL0.
ORSET ; order record set
+1 SET PSGMFOR=""
SET ND2=$GET(^PS(55,PSGP,5,PSGMARO,2))
SET (SD,X)=$PIECE($PIECE(ND2,"^",2),".")
IF X>PSGPLF
QUIT
SET FD=$PIECE($PIECE(ND2,"^",4),".")
SET T=$PIECE(ND2,"^",6)
+2 ;
+3 SET A=$GET(^PS(55,PSGP,5,PSGMARO,8))
IF $PIECE(A,"^")]""
SET PSGMARWN="C!"_$PIECE(A,"^")
IF $GET(SUB1)]""
IF $GET(SUB2)]""
IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
DO SPN
+4 ;
+5 NEW MARX
DO DRGDISP^PSJLMUT1(PSGP,+PSGMARO_"U",20,0,.MARX,1)
+6 ;IHS/MSC/MGH patch 1013 uppercase sort for MAR
+7 SET DRG=$$UP^XLFSTR(MARX(1))_U_PSGMARO_"U"
SET QST=$SELECT(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",$PIECE(ND2,"^")["PRN":"OR",1:"CR")
+8 SET X=""
IF "OB"]QST
IF $PIECE(ND2,U)'["@"
IF $PIECE(ND2,U,2)'>PSGPLS
IF $PIECE(ND2,U,4)'<PSGPLF
IF $PIECE(ND2,U,5)
IF $PIECE(ND2,U,6)<1441
IF $PIECE(ND2,U,6)'="D"
SET X=$PIECE(ND2,U,5)
SET PSGPLC=1
+9 IF '$TEST
IF "OB"]QST
SET PSGPLO=PSGMARO
KILL PSGMAR
DO ^PSGPL0
SET (Q,X)=""
FOR QX=0:0
SET Q=$ORDER(PSGMAR(Q))
IF Q=""
QUIT
SET X=X_$EXTRACT("0",2-$LENGTH(Q))_Q_"-"
+10 SET X=$SELECT(QST["C"!(QST["O"):$PIECE(ND2,"^",5),1:"")_"^"_X
+11 ;
+12 ;DAM 5-01-07 Add next line to include non-IV meds when printing by PATIENT and choosing to print "ALL MEDS"
+13 IF PSGSS="P"
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=X
QUIT
+14 ;
+15 ;DAM 5-01-07 Add check to see if user wants to include ward orders when printing by CLINIC GROUP
+16 IF PSGSS="L"
IF ((PSGINWDG="")&(PSGMARWN'["C!"))
QUIT
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=X
QUIT
+17 ;
+18 ;DAM 5-01-07 Add check to see if user wants to include ward orders when printing by CLINIC
+19 IF PSGSS="C"
IF ((PSGINWD="")&(PSGMARWN'["C!"))
QUIT
IF ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!"))
Begin DoDot:1
+20 SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=X
End DoDot:1
QUIT
+21 IF (PSGSS="L")!(PSGSS="C")
QUIT
+22 ;
+23 ; DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by WARD GROUP
+24 IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
SET ^TMP($JOB,TM,PSGMARWN,SUB1,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=X
+25 ;
+26 ;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by WARD.
+27 IF (PSGSS="W")
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
SET ^TMP($JOB,TM,PSGMARWN,SUB1,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=X
+28 ;
+29 ;DAM 5-01-07 Add an XTMP global to swap location and patient name in the subscripts when printing MAR by WARD/PATIENT or WARD GROUP.
+30 ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
NEW PSGDEM
SET PSGDEM=X
+31 SET PSGREP="PSGM_"_$JOB
+32 SET X1=DT
SET X2=1
DO C^%DTC
KILL %,%H,%T
+33 SET ^XTMP(PSGREP,0)=X_U_DT
+34 ;Construct XTMP global for printing by WARD
IF PSGRBPPN="P"
IF PSGSS="W"
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:1
+35 SET ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=PSGDEM
End DoDot:1
+36 ;Construct XTMP global for printing by WARD GROUP
IF PSGRBPPN="P"
IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:1
+37 SET ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),DRG)=PSGDEM
End DoDot:1
+38 ;transfer contents of patient drug information contained in PSGDEM back to X
SET X=PSGDEM
+39 ;End DAM modifications 5-01-07
+40 QUIT
+41 ;
SPN ; set patient node
+1 DO DIET
+2 SET X=$PIECE(PSGP(0),U)_U_$EXTRACT(...
... $PIECE(PSJPDOB,U,2),1,10)_";"_PSJPAGE_U_VA("PID")_U_PSJPDX_U_PSJPWT_U_PSJPWTD_U_PSJPHT_U_PSJPHTD_U_$PIECE(PSJPAD,U,2)_U_$PIECE(PSJPTD,U,2)_U_$PIECE(PSJPSEX,U,2)_U_PSJPWD_U_PSGPLS_U_PSGPLF_U_PSGMARSD_U_PSGMARFD_U_PSGMARSP_U_PSGMARFP
+3 ;GMZ:PSJ*5*196;Set diet info for each patient.
+4 IF PSGSS="P"!(PSGSS="C")!(PSGSS="L")
SET ^TMP($JOB,PPN)=X_U_PSGMARWN_U_PSJPRB_U_$GET(PSJDIET)
QUIT
+5 ;
+6 ;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by ward.
+7 IF PSGSS="W"
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
SET ^TMP($JOB,TM,PSGMARWN,SUB1,SUB2)=X_U_U_U_$GET(PSJDIET)
+8 ;
+9 ;DAM 5-01-07 Add check to see if user wants to include clinic orders when printing by ward group.
+10 IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
SET ^TMP($JOB,TM,PSGMARWN,SUB1,SUB2)=X_U_U_U_$GET(PSJDIET)
+11 ;
+12 ;DAM 5-01-07 Add an XTMP global to reverse location and patient name in the subscripts when printing MAR by WARD/PATIENT or WARD GROUP.
+13 ;transfer contents of patient demographics contained in "X" above to a new variable temporarily
NEW PSGDEM
SET PSGDEM=X_U_U_U_$GET(PSJDIET)
+14 SET PSGREP="PSGM_"_$JOB
+15 SET X1=DT
SET X2=1
DO C^%DTC
KILL %,%H,%T
+16 SET ^XTMP(PSGREP,0)=X_U_DT
+17 ;Construct XTMP global for printing by WARD
IF PSGRBPPN="P"
IF PSGSS="W"
IF ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:1
+18 SET ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2)=PSGDEM
End DoDot:1
+19 ;Construct XTMP global for printing by WARD GROUP
IF PSGRBPPN="P"
IF PSGSS="G"
IF ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:1
+20 SET ^XTMP(PSGREP,TM,SUB1,PSGMARWN,SUB2)=PSGDEM
End DoDot:1
+21 ;transfer contents of patient demographics contained in PSGDEM back to X
SET X=PSGDEM
+22 ;End DAM modifications 3-7-07
+23 QUIT
DIET ; Include abbr. diet label if indicated in the Site par.
+1 NEW ADM,DFN,PSJMPAR
KILL PSJDIET
+2 ;MGH Set to null due to undefined error
+3 SET Y=""
+4 SET PSJMPAR=$GET(^PS(59.7,1,26))
+5 IF '$PIECE(PSJMPAR,U,3)
QUIT
+6 SET DFN=PSGP
SET ADM=$GET(^DPT("CN",PSGMARWN,DFN))
+7 IF +ADM
DO CUR^FHORD7
SET PSJDIET=Y
+8 QUIT
+9 ;
DTSET ;
+1 SET (PSGPLS,PSGPLF)=PSGMARDT
+2 SET PSJSYSW=$ORDER(^PS(59.6,"B",+$GET(PSJPWD),0))
+3 IF PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+4 IF $DATA(PSJSYSW0)
IF $PIECE(PSJSYSW0,"^",8)
SET ST=$PIECE(PSJSYSW0,"^",8)
SET FT=$PIECE(PSJSYSW0,"^",9)
+5 IF '$TEST
SET ST="0001"
SET FT=24
SET SET PSGMARSD=$EXTRACT(ST,1,2)
SET PSGMARFD=$EXTRACT(FT,1,2)
IF 'PSGMARSD
SET PSGMARSD="01"
SET PSGMARFD=$SELECT(+PSGMARSD=1:24,PSGMARSD=PSGMARFD:PSGMARSD-1,1:PSGMARFD)
IF $LENGTH(PSGMARFD)<2
SET PSGMARFD=0_PSGMARFD
+1 IF ST>1
SET X1=$PIECE(PSGPLF,".")
SET X2=1
DO C^%DTC
SET PSGPLF=X
+2 SET PSGPLS=+(PSGPLS_"."_ST)
SET PSGPLF=+(PSGPLF_"."_FT)
+3 SET PSGMARSP=$$ENDTC2^PSGMI(PSGPLS)
SET PSGMARFP=$$ENDTC2^PSGMI(PSGPLF)
+4 QUIT
