- PSGMAR0 ;BIR/CML3-GATHERS INFO FOR 24 HOUR MAR ; 7/21/08 9:34am
- ;;5.0;INPATIENT MEDICATIONS ;**8,15,20,111,145,196,326**;16 DEC 97;Build 1
- ;
- ; 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.
- ENQ ;
- 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,"^",1)]"")&($P(A,"^",2)]"") 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)
- S DRG=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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMAR0 9660 printed Feb 18, 2025@23:27:51 Page 2
- PSGMAR0 ;BIR/CML3-GATHERS INFO FOR 24 HOUR MAR ; 7/21/08 9:34am
- +1 ;;5.0;INPATIENT MEDICATIONS ;**8,15,20,111,145,196,326**;16 DEC 97;Build 1
- +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.
- ENQ ;
- +1 SET PSGMSORT=$PIECE($GET(^PS(59.7,1,26)),U,4)
- +2 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.)"
- +3 ;
- +4 ;
- 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,"^",1)]"")&($PIECE(A,"^",2)]"")
- 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 SET DRG=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")
- +7 ;
- +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 SET PSJMPAR=$GET(^PS(59.7,1,26))
- +3 if '$PIECE(PSJMPAR,U,3)
- QUIT
- +4 SET DFN=PSGP
- SET ADM=$GET(^DPT("CN",PSGMARWN,DFN))
- +5 IF +ADM
- DO CUR^FHORD7
- SET PSJDIET=Y
- +6 QUIT
- +7 ;
- 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
