- PSJORRO ;BIR/MV - RETURN INPATIENT MEDS (CONDENSED) OLD SORT ;Jun 17, 2020@13:03:07
- ;;5.0;INPATIENT MEDICATIONS;**134,213,225,275,399**;16 DEC 97;Build 64
- ;
- ;Reference to ^PS(52.6 is supported by DBIA 1231.
- ;Reference to ^PS(52.7 is supported by DBIA 2173.
- ;Reference to ^PS(55 is supported by DBIA 2191.
- ;Reference to ^TMP("PS" is documented in DBIA #2383.
- ;Reference to ^SC is documented in DBIA #10040.
- ;Reference to ^PS(50.7 is supported by DBIA #2180.
- ;
- ; return condensed list of inpat meds
- OCL(DFN,BDT,EDT,TFN) ; Execute this section if MVIEW=1
- N ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A,TFN2,PSJOTYP,%
- S TFN2=TFN
- ; PON=placer order number (oerr), FON=filler order number
- ;*225 Add time or use now
- D NOW^%DTC S:BDT="" BDT=% S:BDT'["." BDT=BDT_".000001"
- S:EDT="" EDT=9999999
- S:EDT'["." EDT=EDT_".999999"
- ;*225 Use Correct Start
- S F="^PS(55,DFN,5,",WBDT=BDT F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON S PSJOTYP="D" D UDTMP
- S F="^PS(53.1," F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON S X=$P($G(^PS(53.1,+ON,0)),U,4) S PSJOTYP=$S(PST="P":"P1",1:"P2") D @$S(X="U":"UDTMP",1:"IVTMP")
- S F="^PS(55,"_DFN_",""IV"",",WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON S PSJOTYP="V" D IVTMP
- S X1="" F S X1=$O(^TMP("PSJTMP",$J,X1)) Q:X1="" S X2="" F S X2=$O(^TMP("PSJTMP",$J,X1,X2)) Q:X2="" S X3="" F S X3=$O(^TMP("PSJTMP",$J,X1,X2,X3)) Q:X3="" D
- .S X4="" F S X4=$O(^TMP("PSJTMP",$J,X1,X2,X3,X4)) Q:X4="" S X5="" F S X5=$O(^TMP("PSJTMP",$J,X1,X2,X3,X4,X5)) Q:X5="" D
- ..; The merge below sends the proper ^TMP("PS",$J structure back to the calling routine PSJORRE
- ..S TFN=$G(TFN)+1 M ^TMP("PS",$J,TFN)=^TMP("PSJTMP",$J,X1,X2,X3,X4,X5) S ^TMP("PS",$J,"PC",0)=TFN
- K ^TMP("PSJTMP",$J)
- Q
- ;
- UDTMP ;*** Set ^TMP for Unit dose orders.
- N PROVIDER,RNWDT,EDTCMPLX,NDP2,PSJSTP,PSJLOC,NDDSS
- S (PROVIDER,RNWDT,EDTCMPLX,NDP2,PSJSTP,PSJLOC,NDDSS)=""
- S (MR,SCH,INST,PON)="",FON=+ON_$S(F["53.1":"P",1:"U")
- I $E($G(PSJOTYP))="P",'$G(WBDT) S WBDT=+ON
- D TYPE S PSJLOC=$S($G(PSJCLIN):$P($G(^SC(+PSJCLIN,0)),"^"),1:"zzz")
- S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
- S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
- S ND2=$G(@(F_ON_",2)")) I 'EDTCMPLX I F'["53.1",($P(ND2,U,2)>EDT) Q
- S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F["53.1",($P(ND0,U,16)>EDT) Q
- S STAT=$$CODES^PSIVUTL($P(ND0,U,9),$S(FON["P":53.1,1:55.06),28)
- S ND6=$P($G(@(F_ON_",6)")),"^"),INST=$G(@(F_+ON_",.3)"))
- S:ND6["Instructions too long. See Order View or BCMA for full text" ND6="Instructions too long. See order details for full text."
- S ND8=$P($G(@(F_ON_",8)")),"^")
- S FON=+ON_$S(F["53.1":"P",1:"U"),DO=$P($G(@(F_ON_",.2)")),"^",2)
- D DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1)
- ;*225 Don't allow 0 Units
- S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(+UNITS=0) UNITS=1
- S:+$P(ND0,U,3) MR=$$MR^PSJORRE1(+$P(ND0,U,3))
- N NOTGIVEN S NOTGIVEN=$S(FON["U":$P($G(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
- ;******** GUI 27 old sort, new format for Meds Tab
- I F[53.1 S NDDSS=$G(@(F_ON_",""DSS"")")),LOC=$P(NDDSS,"^")
- S:F'[53.1 LOC=$P(ND8,"^") S LOC=$S(LOC]"":LOC,1:"~") I LOC S LOC=$P($G(^SC(LOC,0)),"^")
- S PSJST=$P(ND0,"^",9)
- S GP=$S((",A,H,")[(","_PSJST_","):2,(",P,N,")[(","_PSJST_","):1,PSJST="E":3,(",DE,DR,D,RE,R,")[(","_PSJST_","):4,1:0)
- S PSJST2=$S(PSJST="A":1,PSJST="R":2,PSJST="H":3,PSJST="S":4,PSJST="P":5,PSJST="O":6,PSJST="N":7,PSJST="I":8,PSJST="P":9,GP=4&($G(PRIO)="D"):10,PSJST="E":11,PSJST="D":12,PSJST="DE":13,PSJST="RE":14,PSJST="R":15,1:0)
- S PSJOI=$P(NDP2,"^"),PSJOINM=$P($G(^PS(50.7,+PSJOI,0)),"^")
- S PSJSTP=+$P(ND2,"^",4)
- ;********
- S TFN2=$G(TFN2)+1
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,0)=FON_";I"_U_DN(1)_"^^"_$P(ND2,U,4)_"^^"_DO_U_UNITS_U_$P(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_$P(ND2,U,2)_U_$G(RNWDT)
- K ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0) I PSJCLIN]"" S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)=PSJCLIN
- S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
- I PROVIDER S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",0)=MR]"" S:MR]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",1,0)=MR
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",1,0)=$P(ND2,U)
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",0)=INST]"" S:INST]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",1,0)=INST
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",1,0)=$P(ND2,U,5)
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",1,0)=ND6
- S:$P($G(@(F_ON_",18)")),U)]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"IND",0)=$P($G(@(F_ON_",18)")),U) ;*399-IND
- Q
- ;
- IVTMP ;*** Set ^TMP for IV orders.
- N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC
- I $E($G(PSJOTYP))="P",'$G(WBDT) S WBDT=+ON
- S NDP2=$G(@(F_ON_",.2)")) S EDTCMPLX=$P(NDP2,"^",8)
- S ND0=$G(@(F_ON_",0)")) I 'EDTCMPLX I F'["53.1",($P(ND0,U,2)>EDT) Q
- D TYPE S PSJLOC=$S($G(PSJCLIN):$P($G(^SC(+PSJCLIN,0)),"^"),1:"zzz")
- S FON=+ON_$S(F["53.1":"P",1:"V"),CNT=0
- S RNWDT=$$LASTREN^PSJLMPRI(DFN,FON) I RNWDT S RNWDT=+RNWDT
- ;******** GUI 27 old sort, new format for Meds Tab
- S NDDSS=$G(@(F_ON_",""DSS"")")),NDP2=$G(@(F_ON_",.2)"))
- S PSJOI=$P(NDP2,"^")
- I F[53.1 S PSJST=$P(ND0,"^",9)
- I F'[53.1 S PSJST=$P(ND0,"^",17)
- S GP=$S((",A,H,")[(","_PSJST_","):2,(",P,N,")[(","_PSJST_","):1,PSJST="E":3,(",DE,DR,D,RE,R,")[(","_PSJST_","):4,1:0)
- S PSJST2=$S(PSJST="A":1,PSJST="R":2,PSJST="H":3,PSJST="S":4,PSJST="P":5,PSJST="O":6,PSJST="N":7,PSJST="I":8,PSJST="P":9,GP=4&($G(PRIO)="D"):10,PSJST="E":11,PSJST="D":12,PSJST="DE":13,PSJST="RE":14,PSJST="R":15,1:0)
- S LOC=$P(NDDSS,"^") S LOC=$S(LOC]"":LOC,1:"~") I LOC S LOC=$P($G(^SC(LOC,0)),"^")
- I PSJOI="" S PSJOINM="Orderable Item Not Found"
- I PSJOI'="" S PSJOINM=$P($G(^PS(50.7,+PSJOI,0)),"^")
- S PSJSTP=$P(ND0,"^",3)
- ;********
- S TFN2=$G(TFN2)+1
- F X=0:0 S X=$O(@(F_ON_",""AD"","_X_")")) Q:'X S ND=$G(@(F_ON_",""AD"","_X_",0)")),DN=$P($G(^PS(52.6,+ND,0)),U),Y=DN_U_$P(ND,U,2) S:$P(ND,U,3) Y=Y_U_$P(ND,U,3) S CNT=CNT+1,^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"A",CNT,0)=Y
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"A",0)=CNT,CNT=0
- F X=0:0 S X=$O(@(F_ON_",""SOL"","_X_")")) Q:'X S ND=$G(@(F_ON_",""SOL"","_X_",0)")),DN=$G(^PS(52.7,+ND,0)),CNT=CNT+1,^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"B",0)=CNT
- S TYPE=$P(ND0,U,4),(MR,SCH,INST,INFUS)=""
- I FON["P" S ND2=$G(^PS(53.1,+ON,2)),SCH=$P(ND2,U),START=$P(ND2,U,2),STOP=$P(ND2,U,4),MR=$P(ND0,U,3),INFUS=$P($G(^PS(53.1,+ON,8)),U,5),STAT=$$CODES^PSIVUTL($P(ND0,U,9),53.1,28),ADM=$P(ND2,U,5),SIO=$P($G(@(F_+ON_",6)")),"^")
- I FON'["P" S START=$P(ND0,U,2),STOP=$P(ND0,U,3),SCH=$P(ND0,U,9),INFUS=$P(ND0,U,8),MR=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,3),STAT=$$CODES^PSIVUTL($P(ND0,U,17),55.01,100),ADM=$P(ND0,U,11),SIO=$P($G(@(F_+ON_",3)")),"^")
- S:($G(SIO)["Instructions too long. See Order View or BCMA for full text") SIO="Instructions too long. See order details for full text."
- S DN=$G(@(F_+ON_",.2)")),DO=$P(DN,U,2)
- S DN=$S(+$P(DN,U):$$OIDF^PSJLMUT1($P(DN,U)),1:"")
- S:MR MR=$$MR^PSJORRE1(+MR),INST=$G(@(F_+ON_",.3)"))
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$P(ND0,"^",21)_U_STAT_U_U_U_U_U_($P(ND0,U,9)="P"&($P(ND0,U,24)="R"))_U_START_U_$G(RNWDT)
- K ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0) I PSJCLIN]"" S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)=PSJCLIN
- S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6)
- I PROVIDER S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
- S ND2P5=$G(@(F_+ON_",2.5)")) S IVLIM=$P(ND2P5,U,4) I $E(IVLIM)="a" S IVLIM="doses"_$P(IVLIM,"a",2)
- I IVLIM="" S IVLIM=$P(ND2P5,U,2) S:(IVLIM'["d")&(IVLIM'["h") IVLIM=""
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",0)=MR]"" S:MR]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",1,0)=MR
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",0)=INST]"" S:INST]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",1,0)=INST
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",1,0)=SCH
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",1,0)=ADM
- S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",1,0)=SIO
- I $G(IVLIM)]"" S ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"IVLIM",0)=IVLIM
- S:$P($G(@(F_ON_",18)")),U)]"" ^TMP("PSJTMP",$J,PSJLOC,GP,PSJST,WBDT,TFN2,"IND",0)=$P($G(@(F_ON_",18)")),U) ;*399-IND
- Q
- STAT(Y,X) ;* Return the full status instead of just the code for U/D.
- S X=$P($P(";"_$P(Y,U,3),";"_X_":",2),";")
- Q X
- TYPE ;determine if this is an IMO order or not
- S (A,PSJCLIN)="" I F["PS(53.1" S A=$G(^PS(53.1,ON,"DSS"))
- I F["PS(55" S A=$S(F["IV":$G(^PS(55,DFN,"IV",ON,"DSS")),1:$G(^PS(55,DFN,5,ON,8)))
- I $P(A,"^",2)'="" S PSJCLIN=+A
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORRO 9581 printed Feb 18, 2025@23:34:50 Page 2
- PSJORRO ;BIR/MV - RETURN INPATIENT MEDS (CONDENSED) OLD SORT ;Jun 17, 2020@13:03:07
- +1 ;;5.0;INPATIENT MEDICATIONS;**134,213,225,275,399**;16 DEC 97;Build 64
- +2 ;
- +3 ;Reference to ^PS(52.6 is supported by DBIA 1231.
- +4 ;Reference to ^PS(52.7 is supported by DBIA 2173.
- +5 ;Reference to ^PS(55 is supported by DBIA 2191.
- +6 ;Reference to ^TMP("PS" is documented in DBIA #2383.
- +7 ;Reference to ^SC is documented in DBIA #10040.
- +8 ;Reference to ^PS(50.7 is supported by DBIA #2180.
- +9 ;
- +10 ; return condensed list of inpat meds
- OCL(DFN,BDT,EDT,TFN) ; Execute this section if MVIEW=1
- +1 NEW ADM,CNT,DN,DO,F,FON,INFUS,INST,MR,ND,ND0,ND2,ND6,ON,PON,PST,SCH,SIO,STAT,TYPE,UNITS,WBDT,X,Y,PSJCLIN,A,TFN2,PSJOTYP,%
- +2 SET TFN2=TFN
- +3 ; PON=placer order number (oerr), FON=filler order number
- +4 ;*225 Add time or use now
- +5 DO NOW^%DTC
- if BDT=""
- SET BDT=%
- if BDT'["."
- SET BDT=BDT_".000001"
- +6 if EDT=""
- SET EDT=9999999
- +7 if EDT'["."
- SET EDT=EDT_".999999"
- +8 ;*225 Use Correct Start
- +9 SET F="^PS(55,DFN,5,"
- SET WBDT=BDT
- FOR
- SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))
- if 'WBDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))
- if 'ON
- QUIT
- SET PSJOTYP="D"
- DO UDTMP
- +10 SET F="^PS(53.1,"
- FOR PST="P","N"
- FOR ON=0:0
- SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))
- if 'ON
- QUIT
- SET X=$PIECE($GET(^PS(53.1,+ON,0)),U,4)
- SET PSJOTYP=$SELECT(PST="P":"P1",1:"P2")
- DO @$SELECT(X="U":"UDTMP",1:"IVTMP")
- +11 SET F="^PS(55,"_DFN_",""IV"","
- SET WBDT=BDT
- FOR
- SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
- if 'WBDT
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
- if 'ON
- QUIT
- SET PSJOTYP="V"
- DO IVTMP
- +12 SET X1=""
- FOR
- SET X1=$ORDER(^TMP("PSJTMP",$JOB,X1))
- if X1=""
- QUIT
- SET X2=""
- FOR
- SET X2=$ORDER(^TMP("PSJTMP",$JOB,X1,X2))
- if X2=""
- QUIT
- SET X3=""
- FOR
- SET X3=$ORDER(^TMP("PSJTMP",$JOB,X1,X2,X3))
- if X3=""
- QUIT
- Begin DoDot:1
- +13 SET X4=""
- FOR
- SET X4=$ORDER(^TMP("PSJTMP",$JOB,X1,X2,X3,X4))
- if X4=""
- QUIT
- SET X5=""
- FOR
- SET X5=$ORDER(^TMP("PSJTMP",$JOB,X1,X2,X3,X4,X5))
- if X5=""
- QUIT
- Begin DoDot:2
- +14 ; The merge below sends the proper ^TMP("PS",$J structure back to the calling routine PSJORRE
- +15 SET TFN=$GET(TFN)+1
- MERGE ^TMP("PS",$JOB,TFN)=^TMP("PSJTMP",$JOB,X1,X2,X3,X4,X5)
- SET ^TMP("PS",$JOB,"PC",0)=TFN
- End DoDot:2
- End DoDot:1
- +16 KILL ^TMP("PSJTMP",$JOB)
- +17 QUIT
- +18 ;
- UDTMP ;*** Set ^TMP for Unit dose orders.
- +1 NEW PROVIDER,RNWDT,EDTCMPLX,NDP2,PSJSTP,PSJLOC,NDDSS
- +2 SET (PROVIDER,RNWDT,EDTCMPLX,NDP2,PSJSTP,PSJLOC,NDDSS)=""
- +3 SET (MR,SCH,INST,PON)=""
- SET FON=+ON_$SELECT(F["53.1":"P",1:"U")
- +4 IF $EXTRACT($GET(PSJOTYP))="P"
- IF '$GET(WBDT)
- SET WBDT=+ON
- +5 DO TYPE
- SET PSJLOC=$SELECT($GET(PSJCLIN):$PIECE($GET(^SC(+PSJCLIN,0)),"^"),1:"zzz")
- +6 SET RNWDT=$$LASTREN^PSJLMPRI(DFN,FON)
- IF RNWDT
- SET RNWDT=+RNWDT
- +7 SET NDP2=$GET(@(F_ON_",.2)"))
- SET EDTCMPLX=$PIECE(NDP2,"^",8)
- +8 SET ND2=$GET(@(F_ON_",2)"))
- IF 'EDTCMPLX
- IF F'["53.1"
- IF ($PIECE(ND2,U,2)>EDT)
- QUIT
- +9 SET ND0=$GET(@(F_ON_",0)"))
- IF 'EDTCMPLX
- IF F["53.1"
- IF ($PIECE(ND0,U,16)>EDT)
- QUIT
- +10 SET STAT=$$CODES^PSIVUTL($PIECE(ND0,U,9),$SELECT(FON["P":53.1,1:55.06),28)
- +11 SET ND6=$PIECE($GET(@(F_ON_",6)")),"^")
- SET INST=$GET(@(F_+ON_",.3)"))
- +12 if ND6["Instructions too long. See Order View or BCMA for full text"
- SET ND6="Instructions too long. See order details for full text."
- +13 SET ND8=$PIECE($GET(@(F_ON_",8)")),"^")
- +14 SET FON=+ON_$SELECT(F["53.1":"P",1:"U")
- SET DO=$PIECE($GET(@(F_ON_",.2)")),"^",2)
- +15 DO DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1)
- +16 ;*225 Don't allow 0 Units
- +17 SET UNITS=""
- IF '$ORDER(@(F_+ON_",1,1)"))
- SET UNITS=$PIECE($GET(@(F_+ON_",1,1,0)")),U,2)
- if (FON["U")&(+UNITS=0)
- SET UNITS=1
- +18 if +$PIECE(ND0,U,3)
- SET MR=$$MR^PSJORRE1(+$PIECE(ND0,U,3))
- +19 NEW NOTGIVEN
- SET NOTGIVEN=$SELECT(FON["U":$PIECE($GET(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
- +20 ;******** GUI 27 old sort, new format for Meds Tab
- +21 IF F[53.1
- SET NDDSS=$GET(@(F_ON_",""DSS"")"))
- SET LOC=$PIECE(NDDSS,"^")
- +22 if F'[53.1
- SET LOC=$PIECE(ND8,"^")
- SET LOC=$SELECT(LOC]"":LOC,1:"~")
- IF LOC
- SET LOC=$PIECE($GET(^SC(LOC,0)),"^")
- +23 SET PSJST=$PIECE(ND0,"^",9)
- +24 SET GP=$SELECT((",A,H,")[(","_PSJST_","):2,(",P,N,")[(","_PSJST_","):1,PSJST="E":3,(",DE,DR,D,RE,R,")[(","_PSJST_","):4,1:0)
- +25 SET PSJST2=$SELECT(PSJST="A":1,PSJST="R":2,PSJST="H":3,PSJST="S":4,PSJST="P":5,PSJST="O":6,PSJST="N":7,PSJST="I":8,PSJST="P":9,GP=4&($GET(PRIO)="D"):10,PSJST="E":11,PSJST="D":12,PSJST="DE":13,PSJST="RE":14,PSJST="R":15,1:0)
- +26 SET PSJOI=$PIECE(NDP2,"^")
- SET PSJOINM=$PIECE($GET(^PS(50.7,+PSJOI,0)),"^")
- +27 SET PSJSTP=+$PIECE(ND2,"^",4)
- +28 ;********
- +29 SET TFN2=$GET(TFN2)+1
- +30 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,0)=FON_";I"_U_DN(1)_"^^"_$PIECE(ND2,U,4)_"^^"_DO_U_UNITS_U_$PIECE(ND0,U,21)_U_STAT_U_U_U_U_NOTGIVEN_U_($PIECE(ND0,U,9)="P"&($PIECE(ND0,U,24)="R"))_U_$PIECE(ND2,U,2)_U_$GET(RNWDT)
- +31 KILL ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)
- IF PSJCLIN]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)=PSJCLIN
- +32 SET PROVIDER=$PIECE($GET(@(F_+ON_",0)")),"^",2)
- +33 IF PROVIDER
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"P",0)=PROVIDER_"^"_$PIECE($GET(^VA(200,PROVIDER,0)),"^")
- +34 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",0)=MR]""
- if MR]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",1,0)=MR
- +35 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",0)=$PIECE(ND2,U)]""
- if $PIECE(ND2,U)]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",1,0)=$PIECE(ND2,U)
- +36 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",0)=INST]""
- if INST]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",1,0)=INST
- +37 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",0)=$PIECE(ND2,U,5)]""
- if $PIECE(ND2,U,5)]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",1,0)=$PIECE(ND2,U,5)
- +38 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",0)=ND6]""
- if ND6]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",1,0)=ND6
- +39 ;*399-IND
- if $PIECE($GET(@(F_ON_",18)")),U)]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"IND",0)=$PIECE($GET(@(F_ON_",18)")),U)
- +40 QUIT
- +41 ;
- IVTMP ;*** Set ^TMP for IV orders.
- +1 NEW PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC
- +2 IF $EXTRACT($GET(PSJOTYP))="P"
- IF '$GET(WBDT)
- SET WBDT=+ON
- +3 SET NDP2=$GET(@(F_ON_",.2)"))
- SET EDTCMPLX=$PIECE(NDP2,"^",8)
- +4 SET ND0=$GET(@(F_ON_",0)"))
- IF 'EDTCMPLX
- IF F'["53.1"
- IF ($PIECE(ND0,U,2)>EDT)
- QUIT
- +5 DO TYPE
- SET PSJLOC=$SELECT($GET(PSJCLIN):$PIECE($GET(^SC(+PSJCLIN,0)),"^"),1:"zzz")
- +6 SET FON=+ON_$SELECT(F["53.1":"P",1:"V")
- SET CNT=0
- +7 SET RNWDT=$$LASTREN^PSJLMPRI(DFN,FON)
- IF RNWDT
- SET RNWDT=+RNWDT
- +8 ;******** GUI 27 old sort, new format for Meds Tab
- +9 SET NDDSS=$GET(@(F_ON_",""DSS"")"))
- SET NDP2=$GET(@(F_ON_",.2)"))
- +10 SET PSJOI=$PIECE(NDP2,"^")
- +11 IF F[53.1
- SET PSJST=$PIECE(ND0,"^",9)
- +12 IF F'[53.1
- SET PSJST=$PIECE(ND0,"^",17)
- +13 SET GP=$SELECT((",A,H,")[(","_PSJST_","):2,(",P,N,")[(","_PSJST_","):1,PSJST="E":3,(",DE,DR,D,RE,R,")[(","_PSJST_","):4,1:0)
- +14 SET PSJST2=$SELECT(PSJST="A":1,PSJST="R":2,PSJST="H":3,PSJST="S":4,PSJST="P":5,PSJST="O":6,PSJST="N":7,PSJST="I":8,PSJST="P":9,GP=4&($GET(PRIO)="D"):10,PSJST="E":11,PSJST="D":12,PSJST="DE":13,PSJST="RE":14,PSJST="R":15,1:0)
- +15 SET LOC=$PIECE(NDDSS,"^")
- SET LOC=$SELECT(LOC]"":LOC,1:"~")
- IF LOC
- SET LOC=$PIECE($GET(^SC(LOC,0)),"^")
- +16 IF PSJOI=""
- SET PSJOINM="Orderable Item Not Found"
- +17 IF PSJOI'=""
- SET PSJOINM=$PIECE($GET(^PS(50.7,+PSJOI,0)),"^")
- +18 SET PSJSTP=$PIECE(ND0,"^",3)
- +19 ;********
- +20 SET TFN2=$GET(TFN2)+1
- +21 FOR X=0:0
- SET X=$ORDER(@(F_ON_",""AD"","_X_")"))
- if 'X
- QUIT
- SET ND=$GET(@(F_ON_",""AD"","_X_",0)"))
- SET DN=$PIECE($GET(^PS(52.6,+ND,0)),U)
- SET Y=DN_U_$PIECE(ND,U,2)
- if $PIECE(ND,U,3)
- SET Y=Y_U_$PIECE(ND,U,3)
- SET CNT=CNT+1
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"A",CNT,0)=Y
- +22 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"A",0)=CNT
- SET CNT=0
- +23 FOR X=0:0
- SET X=$ORDER(@(F_ON_",""SOL"","_X_")"))
- if 'X
- QUIT
- SET ND=$GET(@(F_ON_",""SOL"","_X_",0)"))
- SET DN=$GET(^PS(52.7,+ND,0))
- SET CNT=CNT+1
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"B",CNT,0)=$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(DN,U,4)
- +24 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"B",0)=CNT
- +25 SET TYPE=$PIECE(ND0,U,4)
- SET (MR,SCH,INST,INFUS)=""
- +26 IF FON["P"
- SET ND2=$GET(^PS(53.1,+ON,2))
- SET SCH=$PIECE(ND2,U)
- SET START=$PIECE(ND2,U,2)
- SET STOP=$PIECE(ND2,U,4)
- SET MR=$PIECE(ND0,U,3)
- SET INFUS=$PIECE($GET(^PS(53.1,+ON,8)),U,5)
- SET STAT=$$CODES^PSIVUTL($PIECE(ND0,U,9),53.1,28)
- SET ADM=$PIECE(ND2,U,5)
- SET SIO=$PIECE($GET(@(F_+ON_",6)")),"^")
- +27 IF FON'["P"
- SET START=$PIECE(ND0,U,2)
- SET STOP=$PIECE(ND0,U,3)
- SET SCH=$PIECE(ND0,U,9)
- SET INFUS=$PIECE(ND0,U,8)
- SET MR=$PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),U,3)
- SET STAT=$$CODES^PSIVUTL($PIECE(ND0,U,17),55.01,100)
- SET ADM=$PIECE(ND0,U,11)
- SET SIO=$PIECE($GET(@(F_+ON_",3)")),"^")
- +28 if ($GET(SIO)["Instructions too long. See Order View or BCMA for full text")
- SET SIO="Instructions too long. See order details for full text."
- +29 SET DN=$GET(@(F_+ON_",.2)"))
- SET DO=$PIECE(DN,U,2)
- +30 SET DN=$SELECT(+$PIECE(DN,U):$$OIDF^PSJLMUT1($PIECE(DN,U)),1:"")
- +31 if MR
- SET MR=$$MR^PSJORRE1(+MR)
- SET INST=$GET(@(F_+ON_",.3)"))
- +32 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,0)=FON_";I"_U_DN_U_INFUS_U_STOP_"^^"_DO_"^^"_$PIECE(ND0,"^",21)_U_STAT_U_U_U_U_U_($PIECE(ND0,U,9)="P"&($PIECE(ND0,U,24)="R"))_U_START_U_$GET(RNWDT)
- +33 KILL ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)
- IF PSJCLIN]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"CLINIC",0)=PSJCLIN
- +34 SET PROVIDER=$PIECE($GET(@(F_+ON_",0)")),"^",6)
- +35 IF PROVIDER
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"P",0)=PROVIDER_"^"_$PIECE($GET(^VA(200,PROVIDER,0)),"^")
- +36 SET ND2P5=$GET(@(F_+ON_",2.5)"))
- SET IVLIM=$PIECE(ND2P5,U,4)
- IF $EXTRACT(IVLIM)="a"
- SET IVLIM="doses"_$PIECE(IVLIM,"a",2)
- +37 IF IVLIM=""
- SET IVLIM=$PIECE(ND2P5,U,2)
- if (IVLIM'["d")&(IVLIM'["h")
- SET IVLIM=""
- +38 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",0)=MR]""
- if MR]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"MDR",1,0)=MR
- +39 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",0)=INST]""
- if INST]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIG",1,0)=INST
- +40 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",0)=SCH]""
- if SCH]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SCH",1,0)=SCH
- +41 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",0)=ADM]""
- if ADM]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"ADM",1,0)=ADM
- +42 SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",0)=SIO]""
- if SIO]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"SIO",1,0)=SIO
- +43 IF $GET(IVLIM)]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"IVLIM",0)=IVLIM
- +44 ;*399-IND
- if $PIECE($GET(@(F_ON_",18)")),U)]""
- SET ^TMP("PSJTMP",$JOB,PSJLOC,GP,PSJST,WBDT,TFN2,"IND",0)=$PIECE($GET(@(F_ON_",18)")),U)
- +45 QUIT
- STAT(Y,X) ;* Return the full status instead of just the code for U/D.
- +1 SET X=$PIECE($PIECE(";"_$PIECE(Y,U,3),";"_X_":",2),";")
- +2 QUIT X
- TYPE ;determine if this is an IMO order or not
- +1 SET (A,PSJCLIN)=""
- IF F["PS(53.1"
- SET A=$GET(^PS(53.1,ON,"DSS"))
- +2 IF F["PS(55"
- SET A=$SELECT(F["IV":$GET(^PS(55,DFN,"IV",ON,"DSS")),1:$GET(^PS(55,DFN,5,ON,8)))
- +3 IF $PIECE(A,"^",2)'=""
- SET PSJCLIN=+A
- +4 QUIT