PSJORRN1 ;BIR/JCH-RETURN INPATIENT MEDS (CONDENSED) SECOND 'NEW' SORT ;07 Feb 07 / 12:56 PM
;;5.0; INPATIENT MEDICATIONS ;**134,213**;16 DEC 97;Build 8
;
;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 with Alpha Primary Sort
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,PSJNOW,PSJ30DAY
S TFN2=TFN,PSJNOW=$$DATE^PSJUTL2(),PSJ30DAY=$$FMADD^XLFDT(PSJNOW,-30) S $P(PSJ30DAY,".",2)="000001"
; PON=placer order number (oerr), FON=filler order number
S:BDT="" BDT=DT S WBDT=BDT_".000001" S:WBDT<PSJ30DAY WBDT=PSJ30DAY
S:EDT="" EDT=9999999
S:EDT'["." EDT=EDT_".999999"
S F="^PS(55,DFN,5," 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-1 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="" 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) 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,PSJST2,NDDSS
S (MR,SCH,INST,PON,NDDSS)="",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 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)
S UNITS="" I '$O(@(F_+ON_",1,1)")) S UNITS=$P($G(@(F_+ON_",1,1,0)")),U,2) S:(FON["U")&(UNITS="") 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 New sort format #2 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 PSJST2=$S(PSJST="A":1,PSJST="E":2,1:"") Q:'PSJST2
S PSJOI=$P(NDP2,"^"),PSJOINM=$P($G(^PS(50.7,+PSJOI,0)),"^")
S PSJSTP=+$P(ND2,"^",4)
;********
S TFN2=$G(TFN2)+1
S DN(1)=$S($G(DN(1))="":"UNKNOWN",1:DN(1))
S ^TMP("PSJTMP",$J,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0) I PSJCLIN]"" S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)=PSJCLIN
S PROVIDER=$P($G(@(F_+ON_",0)")),"^",2)
I PROVIDER S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"P",0)=PROVIDER_"^"_$P($G(^VA(200,PROVIDER,0)),"^")
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"MDR",0)=MR]"" S:MR]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"MDR",1,0)=MR
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SCH",0)=$P(ND2,U)]"" S:$P(ND2,U)]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SCH",1,0)=$P(ND2,U)
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIG",0)=INST]"" S:INST]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIG",1,0)=INST
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"ADM",0)=$P(ND2,U,5)]"" S:$P(ND2,U,5)]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"ADM",1,0)=$P(ND2,U,5)
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIO",0)=ND6]"" S:ND6]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIO",1,0)=ND6
Q
;
IVTMP ;*** Set ^TMP for IV orders.
N PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC,NDDSS
S (PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC,NDDSS)=""
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,"^"),PSJST=""
I F[53.1 S PSJST=$P(ND0,"^",9)
I F'[53.1 S PSJST=$P(ND0,"^",17)
S PSJST2=$S(PSJST="A":1,PSJST="E":2,1:"") Q:'PSJST2
S LOC=$P(NDDSS,"^") S LOC=$S(LOC]"":LOC,1:"~") I LOC S LOC=$P($G(^SC(LOC,0)),"^")
I PSJOI'="" S PSJOINM=$P($G(^PS(50.7,+PSJOI,0)),"^")
I PSJOI="" S PSJOINM="Orderable Item Not Found"
S PSJSTP=$P(ND0,"^",3)
;********
S TFN2=$G(TFN2)+1
S DN(1)=$S($G(DN(1))="":"UNKNOWN",1:DN(1)),CNT=0
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,DN(CNT)=Y S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"A",CNT,0)=Y
S ^TMP("PSJTMP",$J,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"B",CNT,0)=$P(DN,U)_U_$P(ND,U,2)_U_$P(DN,U,4)
S ^TMP("PSJTMP",$J,DN(1),PSJST2,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 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,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0) I PSJCLIN]"" S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)=PSJCLIN
S PROVIDER=$P($G(@(F_+ON_",0)")),"^",6)
I PROVIDER S ^TMP("PSJTMP",$J,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"MDR",0)=MR]"" S:MR]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"MDR",1,0)=MR
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIG",0)=INST]"" S:INST]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIG",1,0)=INST
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SCH",0)=SCH]"" S:SCH]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SCH",1,0)=SCH
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"ADM",0)=ADM]"" S:ADM]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"ADM",1,0)=ADM
S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIO",0)=SIO]"" S:SIO]"" ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"SIO",1,0)=SIO
I $G(IVLIM)]"" S ^TMP("PSJTMP",$J,DN(1),PSJST2,WBDT,TFN2,"IVLIM",0)=IVLIM
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
PSJORRN1 ;BIR/JCH-RETURN INPATIENT MEDS (CONDENSED) SECOND 'NEW' SORT ;07 Feb 07 / 12:56 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**134,213**;16 DEC 97;Build 8
+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 with Alpha Primary Sort
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,PSJNOW,PSJ30DAY
+2 SET TFN2=TFN
SET PSJNOW=$$DATE^PSJUTL2()
SET PSJ30DAY=$$FMADD^XLFDT(PSJNOW,-30)
SET $PIECE(PSJ30DAY,".",2)="000001"
+3 ; PON=placer order number (oerr), FON=filler order number
+4 IF BDT=""
SET BDT=DT
SET WBDT=BDT_".000001"
IF WBDT<PSJ30DAY
SET WBDT=PSJ30DAY
+5 IF EDT=""
SET EDT=9999999
+6 IF EDT'["."
SET EDT=EDT_".999999"
+7 SET F="^PS(55,DFN,5,"
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
+8 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")
+9 SET F="^PS(55,"_DFN_",""IV"","
SET WBDT=BDT-1
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
+10 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
+11 SET X4=""
FOR
SET X4=$ORDER(^TMP("PSJTMP",$JOB,X1,X2,X3,X4))
IF X4=""
QUIT
Begin DoDot:2
+12 ; The merge below sends the proper ^TMP("PS",$J structure back to the calling routine PSJORRE
+13 SET TFN=$GET(TFN)+1
MERGE ^TMP("PS",$JOB,TFN)=^TMP("PSJTMP",$JOB,X1,X2,X3,X4)
SET ^TMP("PS",$JOB,"PC",0)=TFN
End DoDot:2
End DoDot:1
+14 KILL ^TMP("PSJTMP",$JOB)
+15 QUIT
+16 ;
UDTMP ;*** Set ^TMP for Unit dose orders.
+1 NEW PROVIDER,RNWDT,EDTCMPLX,NDP2,PSJSTP,PSJLOC,PSJST2,NDDSS
+2 SET (MR,SCH,INST,PON,NDDSS)=""
SET FON=+ON_$SELECT(F["53.1":"P",1:"U")
+3 IF $EXTRACT($GET(PSJOTYP))="P"
IF '$GET(WBDT)
SET WBDT=+ON
+4 DO TYPE
SET PSJLOC=$SELECT($GET(PSJCLIN):$PIECE($GET(^SC(+PSJCLIN,0)),"^"),1:"zzz")
+5 SET RNWDT=$$LASTREN^PSJLMPRI(DFN,FON)
IF RNWDT
SET RNWDT=+RNWDT
+6 SET NDP2=$GET(@(F_ON_",.2)"))
SET EDTCMPLX=$PIECE(NDP2,"^",8)
+7 SET ND2=$GET(@(F_ON_",2)"))
IF 'EDTCMPLX
IF F'["53.1"
IF ($PIECE(ND2,U,2)>EDT)
QUIT
+8 SET ND0=$GET(@(F_ON_",0)"))
IF 'EDTCMPLX
IF F["53.1"
IF ($PIECE(ND0,U,16)>EDT)
QUIT
+9 SET STAT=$$CODES^PSIVUTL($PIECE(ND0,U,9),$SELECT(FON["P":53.1,1:55.06),28)
+10 SET ND6=$PIECE($GET(@(F_ON_",6)")),"^")
SET INST=$GET(@(F_+ON_",.3)"))
+11 SET ND8=$PIECE($GET(@(F_ON_",8)")),"^")
+12 SET FON=+ON_$SELECT(F["53.1":"P",1:"U")
SET DO=$PIECE($GET(@(F_ON_",.2)")),"^",2)
+13 DO DRGDISP^PSJLMUT1(DFN,FON,40,0,.DN,1)
+14 SET UNITS=""
IF '$ORDER(@(F_+ON_",1,1)"))
SET UNITS=$PIECE($GET(@(F_+ON_",1,1,0)")),U,2)
IF (FON["U")&(UNITS="")
SET UNITS=1
+15 IF +$PIECE(ND0,U,3)
SET MR=$$MR^PSJORRE1(+$PIECE(ND0,U,3))
+16 NEW NOTGIVEN
SET NOTGIVEN=$SELECT(FON["U":$PIECE($GET(^PS(55,DFN,5,+ON,0)),"^",22),1:"")
+17 ;******** GUI 27 New sort format #2 for Meds Tab
+18 IF F[53.1
SET NDDSS=$GET(@(F_ON_",""DSS"")"))
SET LOC=$PIECE(NDDSS,"^")
+19 IF F'[53.1
SET LOC=$PIECE(ND8,"^")
SET LOC=$SELECT(LOC]"":LOC,1:"~")
IF LOC
SET LOC=$PIECE($GET(^SC(LOC,0)),"^")
+20 SET PSJST=$PIECE(ND0,"^",9)
SET PSJST2=$SELECT(PSJST="A":1,PSJST="E":2,1:"")
IF 'PSJST2
QUIT
+21 SET PSJOI=$PIECE(NDP2,"^")
SET PSJOINM=$PIECE($GET(^PS(50.7,+PSJOI,0)),"^")
+22 SET PSJSTP=+$PIECE(ND2,"^",4)
+23 ;********
+24 SET TFN2=$GET(TFN2)+1
+25 SET DN(1)=$SELECT($GET(DN(1))="":"UNKNOWN",1:DN(1))
+26 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,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)
+27 KILL ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)
IF PSJCLIN]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)=PSJCLIN
+28 SET PROVIDER=$PIECE($GET(@(F_+ON_",0)")),"^",2)
+29 IF PROVIDER
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"P",0)=PROVIDER_"^"_$PIECE($GET(^VA(200,PROVIDER,0)),"^")
+30 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"MDR",0)=MR]""
IF MR]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"MDR",1,0)=MR
+31 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SCH",0)=$PIECE(ND2,U)]""
IF $PIECE(ND2,U)]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SCH",1,0)=$PIECE(ND2,U)
+32 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIG",0)=INST]""
IF INST]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIG",1,0)=INST
+33 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"ADM",0)=$PIECE(ND2,U,5)]""
IF $PIECE(ND2,U,5)]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"ADM",1,0)=$PIECE(ND2,U,5)
+34 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIO",0)=ND6]""
IF ND6]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIO",1,0)=ND6
+35 QUIT
+36 ;
IVTMP ;*** Set ^TMP for IV orders.
+1 NEW PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC,NDDSS
+2 SET (PROVIDER,START,STOP,EDTCMPLX,NDP2,IVLIM,PSJLOC,NDDSS)=""
+3 IF $EXTRACT($GET(PSJOTYP))="P"
IF '$GET(WBDT)
SET WBDT=+ON
+4 SET NDP2=$GET(@(F_ON_",.2)"))
SET EDTCMPLX=$PIECE(NDP2,"^",8)
+5 SET ND0=$GET(@(F_ON_",0)"))
IF 'EDTCMPLX
IF F'["53.1"
IF ($PIECE(ND0,U,2)>EDT)
QUIT
+6 DO TYPE
SET PSJLOC=$SELECT($GET(PSJCLIN):$PIECE($GET(^SC(+PSJCLIN,0)),"^"),1:"zzz")
+7 SET FON=+ON_$SELECT(F["53.1":"P",1:"V")
SET CNT=0
+8 SET RNWDT=$$LASTREN^PSJLMPRI(DFN,FON)
IF RNWDT
SET RNWDT=+RNWDT
+9 ;******** GUI 27 old sort, new format for Meds Tab
+10 SET NDDSS=$GET(@(F_ON_",""DSS"")"))
SET NDP2=$GET(@(F_ON_",.2)"))
+11 SET PSJOI=$PIECE(NDP2,"^")
SET PSJST=""
+12 IF F[53.1
SET PSJST=$PIECE(ND0,"^",9)
+13 IF F'[53.1
SET PSJST=$PIECE(ND0,"^",17)
+14 SET PSJST2=$SELECT(PSJST="A":1,PSJST="E":2,1:"")
IF 'PSJST2
QUIT
+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=$PIECE($GET(^PS(50.7,+PSJOI,0)),"^")
+17 IF PSJOI=""
SET PSJOINM="Orderable Item Not Found"
+18 SET PSJSTP=$PIECE(ND0,"^",3)
+19 ;********
+20 SET TFN2=$GET(TFN2)+1
+21 SET DN(1)=$SELECT($GET(DN(1))="":"UNKNOWN",1:DN(1))
SET CNT=0
+22 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 DN(CNT)=Y
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"A",CNT,0)=Y
+23 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"A",0)=CNT
SET CNT=0
+24 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,DN(1),PSJST2,WBDT,TFN2,"B",CNT,0)=$PIECE(DN,U)_U_$PIECE(ND,U,2)_U_$PIECE(DN,U,4)
+25 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"B",0)=CNT
+26 SET TYPE=$PIECE(ND0,U,4)
SET (MR,SCH,INST,INFUS)=""
+27 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)")),"^")
+28 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)")),"^")
+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,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)
IF PSJCLIN]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"CLINIC",0)=PSJCLIN
+34 SET PROVIDER=$PIECE($GET(@(F_+ON_",0)")),"^",6)
+35 IF PROVIDER
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,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,DN(1),PSJST2,WBDT,TFN2,"MDR",0)=MR]""
IF MR]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"MDR",1,0)=MR
+39 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIG",0)=INST]""
IF INST]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIG",1,0)=INST
+40 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SCH",0)=SCH]""
IF SCH]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SCH",1,0)=SCH
+41 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"ADM",0)=ADM]""
IF ADM]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"ADM",1,0)=ADM
+42 SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIO",0)=SIO]""
IF SIO]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"SIO",1,0)=SIO
+43 IF $GET(IVLIM)]""
SET ^TMP("PSJTMP",$JOB,DN(1),PSJST2,WBDT,TFN2,"IVLIM",0)=IVLIM
+44 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
