PSJHLU ;BIR/RLW - UTILITIES USED IN BUILDING HL7 SEGMENTS ;4/24/12 2:52pm
;;5.0;INPATIENT MEDICATIONS;**1,56,72,102,134,181,267,285,317,339,364,446**;16 DEC 97;Build 1
;
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^VA(200 is supported by DBIA 10060.
; Reference to ^PS(55 is supported by DBIA# 2191.
;
;*267 Change NTE|21 so it can send over the Long Wp Special Inst/
; Other Prt Info fields if populated.
;*364 Add HAZ Handle & Haz Dispose flags to new ZZZ segment for BCBU
;*446 Fix infusion rate evaluation in ENI tag to determine when to add
; "ml/hr". Continuous orders with rate < 1 were adding extra "ml/hr".
;
INIT ; set up HL7 application variables
S PSJHLSDT="PS",PSJHINST=$P($$SITE^VASITE(),"^")
S PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)="""""
Q
;
SEGMENT(LIMIT) ;
K SEGMENT
N SUBSEG,SEGLENGT S SUBSEG=0,SEGMENT="" F J=0:1:LIMIT D
.I SEGMENT']"" S SEGMENT=FIELD(J) Q
.S SEGMENT=SEGMENT_"|"_FIELD(J)
F S SEGLENGT=$L(SEGMENT) D Q:$L(SEGMENT)'>246
.I SEGLENGT'>246 S SEGMENT(SUBSEG)=SEGMENT
.I SEGLENGT>245 S SEGMENT(SUBSEG)=$E(SEGMENT,1,245),SUBSEG=SUBSEG+1 D
..S SEGMENT=$E(SEGMENT,246,SEGLENGT),SEGMENT(SUBSEG)=$E(SEGMENT,1,245)
SET S PSJI=PSJI+1,^TMP("PSJHLS",$J,PSJHLSDT,PSJI)=SEGMENT(0)
F J=1:1 Q:'$D(SEGMENT(J)) S ^TMP("PSJHLS",$J,PSJHLSDT,PSJI,J)=SEGMENT(J)
Q
;
SEGMENT2 ; Retrieve text fields
K SEGMENT S JJ=0 F S JJ=$O(@(PSJORDER_"12,"_JJ_")")) Q:'JJ S SEGMENT(JJ-1)=$G(@(PSJORDER_"12,"_JJ_",0)"))
I $D(SEGMENT(0)) S SEGMENT(0)="NTE|6|L|"_$S($G(PSJBCBU):SEGMENT(0),1:$$ESC^ORHLESC(SEGMENT(0))) D
.D SET^PSJHLU K SEGMENT,JJ
;build NTE 21 with Special Inst/Other Prt Info Wp fields *267
N QQ K ^TMP("PSJBCMA5",$J)
D GETSIOPI^PSJBCMA5(PSJHLDFN,RXORDER,1)
I RXORDER["V"!(RXORDER["U") I ($G(PSJORD)["P"),($P($G(^PS(53.1,+PSJORD,0)),"^",25)=RXORDER) D
.D GETSIOPI^PSJBCMA5(PSJHLDFN,PSJORD,1)
.N LINES,TEXT1 S LINES=($G(^TMP("PSJBCMA5",$J,PSJHLDFN,PSJORD))),TEXT1=$G(^TMP("PSJBCMA5",$J,PSJHLDFN,PSJORD,1))
.I LINES<1!(LINES=1&(TEXT1["Instructions too long. See Order View or BCMA for full text")) Q
.K ^TMP("PSJBCMA5",$J,PSJHLDFN,RXORDER) M ^TMP("PSJBCMA5",$J,PSJHLDFN,RXORDER)=^TMP("PSJBCMA5",$J,PSJHLDFN,PSJORD) K ^TMP("PSJBCMA5",$J,PSJHLDFN,PSJORD)
F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,PSJHLDFN,RXORDER,QQ)) Q:'QQ D
.I QQ=1 D Q
..S SEGMENT(0)="NTE|21|L|"_$$ESC^ORHLESC(^TMP("PSJBCMA5",$J,PSJHLDFN,RXORDER,QQ))
..S:$G(PSJBCBU) SEGMENT(0)=SEGMENT(0)_"\.br\"
.S SEGMENT(QQ-1)=$$ESC^ORHLESC(^TMP("PSJBCMA5",$J,PSJHLDFN,RXORDER,QQ))
.S:$G(PSJBCBU) SEGMENT(QQ-1)=SEGMENT(QQ-1)_"\.br\"
I $D(SEGMENT(0)) D SET^PSJHLU K SEGMENT,^TMP("PSJBCMA5",$J)
;*267 end
Q
;
CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders
; HLEVN = number of segments in message
;*317
N PADE,PDTYP S PADE=0,PDTYP=""
I PSJORDER["^PS(55," D
. I $O(XQORMSG(0))&((PSOC="DR")!(PSOC="OD")) S PADE=1,PDTYP=PSOC Q
. I '$O(XQORMSG(0)) D
.. N PD0,PD1 S PD0=$G(@(PSJORDER_"0)"))
.. S PD1=$S(RXORDER["V":$P(PD0,"^",17),1:$P(PD0,"^",9)) Q:PD1=""
.. I ",A,D,H,"[(","_$E(PD1)_",") S PADE=1,PDTYP=PSOC
K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT,% ;*364 move kill PSJORDER to later for PADE
I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q
S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
I PADE N RXO,PDMSG S RXO=RXORDER_$S(+RXORDER=RXORDER:"U",1:"") M PDMSG=^TMP("PSJHLS",$J,"PS") ;*317
D MSG^XQOR("PS EVSEND OR",.PSJMSG)
I PADE D PDORD^PSJPDCLU ;*317
I $G(RXORDER),$G(PSJHLDFN) N PSJSTOP S PSJSTOP=$S(RXORDER["U":$P(^PS(55,PSJHLDFN,5,+RXORDER,2),"^",4),RXORDER["V":$P(^PS(55,PSJHLDFN,"IV",+RXORDER,0),"^",3),1:"") I PSJSTOP D
.N PSJSTATU S PSJSTATU=$S(RXORDER["U":$P(^PS(55,PSJHLDFN,5,+RXORDER,0),"^",9),RXORDER["V":$P(^PS(55,PSJHLDFN,"IV",+RXORDER,0),"^",17),1:"")
.I ",A,H,"[(","_PSJSTATU_",") D NOW^%DTC I PSJSTOP'>% N RXON S RXON=RXORDER D EXPIR^PSJHL6
K PSJORDER ;*364 moved to here
Q
;
IVTYPE(PSJORDER) ; check whether a back-door order is Inpatient IV or IV fluid
I RXORDER["V",$P($G(@(PSJORDER_"0)")),"^",4)'="A" Q "I"
I RXORDER["P" I $P($G(@(PSJORDER_"0)")),"^",4)'="F" S IVTYPE="" Q IVTYPE
N SUB,AD,SOL,IVTYPE,NODE1 S SUB=0,IVTYPE="F"
;naked reference on line below refers to the full indirect reference of PSJORDER_ which is from ^PS(55,DFN,"IV",PSJORD
F TYPE="AD","SOL" S SUB=0 F S SUB=$O(@(PSJORDER_""""_TYPE_""""_","_SUB_")")) Q:(SUB="")!(IVTYPE="I") S NODE1=$G(^(SUB,0)) Q:NODE1="" D Q:IVTYPE="I"
.I TYPE="AD" D
..I '$P($G(^PS(52.6,$P(NODE1,"^"),0)),"^",13) S IVTYPE="I"
.D:TYPE="SOL"
..S:'$P($G(^PS(52.7,$P(NODE1,"^"),0)),"^",13) IVTYPE="I"
Q IVTYPE
ENI ;Calculate Frequency for IV orders
N INFUSE
I X?.E1L.E S INFUSE=$$ENLU^PSGMI(X) Q:(INFUSE="TITRATE")!(INFUSE="BOLUS")!($P(INFUSE," ")="INFUSE")!($P(INFUSE," ")="Infuse")
Q:(X="TITRATE")!(X="BOLUS")!($P(X," ")="INFUSE")!($P(X," ")="Infuse")
Q:$$INTRMT(X)
K:$L(X)<1!($L(X)>30)!(X["""")!($A(X)=45) X I '$D(X) Q
I X["=" D Q ; NOIS LOU-0501-42191
.N X2,X1 S X1=$P(X,"="),X2=$P(X,"=",2)
.I X1["ML/HR",(+X1=$P(X1,"ML/HR"))!(+X1=$P(X1," ML/HR")) D
..S X1=$TR(X1,"ML/HR","ml/hr")
.I X2["ML/HR",(+X2=$P(X2,"ML/HR"))!(+X2=$P(X2," ML/HR")) D
..S X2=$TR(X2,"ML/HR","ml/hr")
.I X1[" ml/hr",(+X1=$P(X1," ml/hr")) D
..S X1=$P(X1," ml/hr")_$P(X1," ml/hr",2,9999)
.I X2[" ml/hr",(+X2=$P(X2," ml/hr")) D
..S X2=$P(X2," ml/hr")_$P(X2," ml/hr",2,9999)
.I X1["ml/hr",(+X1=$P(X1,"ml/hr")) D
..S X1=$P(X1,"ml/hr")_$P(X1,"ml/hr",2,9999)
.I X2["ml/hr",(+X2=$P(X2,"ml/hr")) D
..S X2=$P(X2,"ml/hr")_$P(X2,"ml/hr",2,9999)
.I X2'=+X2 D
..I ($P(X2,"@",2,999)'=+$P(X2,"@",2,999)!(+$P(X2,"@",2,999)<0)) K X Q
.I X1=+X1 S X1=X1_" ml/hr"
.I X2=+X2 S X2=X2_" ml/hr"
.S:$P(X2,"@")=+X2 $P(X2,"@")=$P(X2,"@")_" ml/hr"
.S X=X1_"="_X2
;*285 - Allow for decimals with trailing zeroes
I X'?.N.1".".N,($P($TR(X," ml/hr",""),"@",2,999)'=+$P($TR(X," ml/hr",""),"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'?.N.1".".N!(+$P(X," ml/hr")<0)) Q:(X>0&($E(X)=0)) K X Q
; *446 - Fix infusion rate evaluation below
; I X=+X!(X>0&($E(X)=0)) S:$S(X'["ml/hr":0,X["@":0,1:1) X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
I (X=+X)!(X>0&($E(X)=0)) S X=$S(((X'["ml/hr")&(X'["@")):X_" ml/hr",1:X) D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
; *446 End
I X[" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
S SPSOL=$P(X,"@",2) S:$P(X,"@")=+X $P(X,"@")=$P(X,"@")_" ml/hr" S FREQ=$S('SPSOL:0,1:1440/SPSOL\1) K SPSOL
Q
SPSOL S SPSOL=+TVOLUME Q
INTRMT(X) ;
Q:'$P(X," ") 0
Q:$P(X," ",2)="Minutes" 1
Q:$P(X," ",2)="Hours" 1
Q 0
IVCAT(DFN,PSJORD,PARRAY) ; This returns the IV CATEGORY based on the IV TYPE and CHEMO TYPE (not what is already in the IV CATEGORY field)
; Passed in: PSJORDER (file root of order)
N NODE,TYP,CHEMTYP,INTSYR,ND2P5
S (CHEMTYP,INTSYR)=""
S TYP=$G(P(4)),INTSYR=$G(P(5)),CHEMTYP=$G(P(23))
I TYP="",$G(PSJORD)["V" S NODE=$G(^PS(55,DFN,"IV",+PSJORD,0)) S TYP=$P(NODE,"^",4),INTSYR=$P(NODE,"^",5),CHEMTYP=$P(NODE,"^",23)
I TYP="",$G(PSJORD)["P" S NODE=$G(^PS(53.1,+PSJORD,8)) S TYP=$P(NODE,"^"),INTSYR=$P(NODE,"^",4),CHEMTYP=$P(NODE,"^",2)
I TYP="" S TYP=$G(PARRAY(4)),INTSYR=$G(PARRAY(5)),CHEMTYP=$G(PARRAY(23))
Q:$G(TYP)="" ""
S CAT=$S(",A,H,"[(","_TYP_","):"C",TYP="C"&(",A,H,S,"[(","_CHEMTYP_",")&'INTSYR):"C",TYP="C"&(CHEMTYP="P"):"I",TYP="S"&'INTSYR:"C",TYP="P":"I",$G(INTSYR):"I",1:"")
Q CAT
ZRX ; Perform outbound processing
N NODE1
S NODE1=$G(@(PSJORDER_"0)"))
S LIMIT=6 X PSJCLEAR
S FIELD(0)="ZRX"
I '$G(PSJREN) N PREON,PSJREN I $G(PSJORD)["U"&($P(NODE1,"^",24)="R") S PSJREN=1
I $G(PSJORD)["V"&($P(NODE2,"^",8)="R") S PSJREN=1
S PREON=$S($G(PSJREN):$G(PSJORD),PSJORDER["IV":$P(NODE2,"^",5),1:$P(NODE1,"^",25))
S FIELD(1)=$S(PREON["P":$P($G(^PS(53.1,+PREON,0)),"^",21),PREON["V":$P($G(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$P($G(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21))
S FIELD(2)=$S(PSJORDER["IV":$G(P("NAT")),1:$G(PSJNOO))
S FIELD(3)=$S($G(PSJREN):"R",PSJORDER["IV":$P(NODE2,"^",8),1:$P(NODE1,"^",24))
I FIELD(3)="" I PSOC="SN" S FIELD(3)="N"
I $D(P)>1 S FIELD(6)=$$IVCAT^PSJHLU(PSJHLDFN,RXORDER,.P)
S NAME=$P($G(^VA(200,DUZ,0)),"^")
S FIELD(5)=DUZ_"^"_$S($G(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))_"^"_"99NP"
D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
Q
;
ZZZ ; BCBU ZZZ Seg, Hazardous drug flags ZZZ.4 & ZZZ.5 *364
N NODE1,HAZ
S NODE1=$G(@(PSJORDER_"0)"))
S LIMIT=5 X PSJCLEAR
S FIELD(0)="ZZZ"
;Field(1-3) below, not used for BCBU reserved for PADE in PSJPDCLU
S FIELD(1)=""
S FIELD(2)=""
S FIELD(3)=""
S HAZ=$$HAZDRUG(PSJORDER) ;get Haz flag 1 or 0 value and convert flags to HL7 Y or N values
S FIELD(4)=$S($P(HAZ,U):"Y",1:"N")
S FIELD(5)=$S($P(HAZ,U,2):"Y",1:"N")
;set fields into segment temp global
D SEGMENT^PSJHLU(LIMIT),DISPLAY^PSJHL2
Q
;
HAZDRUG(FILE) ;Get Hazardous to Handle and Hazardous to Dispose fields per this order (if any component is Haz then order is) *364
; FILE = file root + Order Num from inpatient variables during workflow; Example VAR contains: "^PS(55,DFN,5,ON," or "(PS(53.1,ON," or "^PS(55,DFN,"IV",ON,"
; (build ROOT to the multiple level to find all Disp Drugs or Additives or Solution and check for any HAZ components.)
N QQ,ROOT,NXTROOT,NXT,IFN,GL,HAZH,HAZD,HZIFN
S (HAZH,HAZD,HZIFN)=0
;check IF Unit Dose Disp Drug exists this order, then get IEN and Haz flags
F QQ=0:0 S ROOT=FILE_"1,"_QQ_")" S QQ=$O(@ROOT) Q:'QQ D
. S NXTROOT=FILE_"1,"_QQ_")" S NXT=$O(@NXTROOT) S GL=$E(NXTROOT,1,$L(ROOT)-1),IFN=+@(GL_",0)")
. S:$P($$HAZ^PSSUTIL(IFN),U,1) HAZH=1,HZIFN=IFN
. S:$P($$HAZ^PSSUTIL(IFN),U,2) HAZD=1,HZIFN=IFN
. ;check IF IV additives exists this order, then get IEN and Haz flags
F QQ=0:0 S ROOT=FILE_"""AD"","_QQ_")" S QQ=$O(@ROOT) Q:'QQ D
. S NXTROOT=FILE_"""AD"","_QQ_")" S NXT=$O(@NXTROOT) S GL=$E(NXTROOT,1,$L(ROOT)-1),IFN=+@(GL_",0)")
. S:IFN IFN=+$P($G(^PS(52.6,IFN,0)),U,2)
. S:$P($$HAZ^PSSUTIL(IFN),U,1) HAZH=1,HZIFN=IFN
. S:$P($$HAZ^PSSUTIL(IFN),U,2) HAZD=1,HZIFN=IFN
F QQ=0:0 S ROOT=FILE_"""SOL"","_QQ_")" S QQ=$O(@ROOT) Q:'QQ D
. S NXTROOT=FILE_"""SOL"","_QQ_")" S NXT=$O(@NXTROOT) S GL=$E(NXTROOT,1,$L(ROOT)-1),IFN=+@(GL_",0)")
. S:IFN IFN=+$P($G(^PS(52.7,IFN,0)),U,2)
. S:$P($$HAZ^PSSUTIL(IFN),U,1) HAZH=1,HZIFN=IFN
. S:$P($$HAZ^PSSUTIL(IFN),U,2) HAZD=1,HZIFN=IFN
Q HAZH_U_HAZD_U_HZIFN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHLU 10683 printed Oct 16, 2024@18:07:51 Page 2
PSJHLU ;BIR/RLW - UTILITIES USED IN BUILDING HL7 SEGMENTS ;4/24/12 2:52pm
+1 ;;5.0;INPATIENT MEDICATIONS;**1,56,72,102,134,181,267,285,317,339,364,446**;16 DEC 97;Build 1
+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 ^VA(200 is supported by DBIA 10060.
+6 ; Reference to ^PS(55 is supported by DBIA# 2191.
+7 ;
+8 ;*267 Change NTE|21 so it can send over the Long Wp Special Inst/
+9 ; Other Prt Info fields if populated.
+10 ;*364 Add HAZ Handle & Haz Dispose flags to new ZZZ segment for BCBU
+11 ;*446 Fix infusion rate evaluation in ENI tag to determine when to add
+12 ; "ml/hr". Continuous orders with rate < 1 were adding extra "ml/hr".
+13 ;
INIT ; set up HL7 application variables
+1 SET PSJHLSDT="PS"
SET PSJHINST=$PIECE($$SITE^VASITE(),"^")
+2 SET PSJCLEAR="K FIELD F J=0:1:LIMIT S FIELD(J)="""""
+3 QUIT
+4 ;
SEGMENT(LIMIT) ;
+1 KILL SEGMENT
+2 NEW SUBSEG,SEGLENGT
SET SUBSEG=0
SET SEGMENT=""
FOR J=0:1:LIMIT
Begin DoDot:1
+3 IF SEGMENT']""
SET SEGMENT=FIELD(J)
QUIT
+4 SET SEGMENT=SEGMENT_"|"_FIELD(J)
End DoDot:1
+5 FOR
SET SEGLENGT=$LENGTH(SEGMENT)
Begin DoDot:1
+6 IF SEGLENGT'>246
SET SEGMENT(SUBSEG)=SEGMENT
+7 IF SEGLENGT>245
SET SEGMENT(SUBSEG)=$EXTRACT(SEGMENT,1,245)
SET SUBSEG=SUBSEG+1
Begin DoDot:2
+8 SET SEGMENT=$EXTRACT(SEGMENT,246,SEGLENGT)
SET SEGMENT(SUBSEG)=$EXTRACT(SEGMENT,1,245)
End DoDot:2
End DoDot:1
if $LENGTH(SEGMENT)'>246
QUIT
SET SET PSJI=PSJI+1
SET ^TMP("PSJHLS",$JOB,PSJHLSDT,PSJI)=SEGMENT(0)
+1 FOR J=1:1
if '$DATA(SEGMENT(J))
QUIT
SET ^TMP("PSJHLS",$JOB,PSJHLSDT,PSJI,J)=SEGMENT(J)
+2 QUIT
+3 ;
SEGMENT2 ; Retrieve text fields
+1 KILL SEGMENT
SET JJ=0
FOR
SET JJ=$ORDER(@(PSJORDER_"12,"_JJ_")"))
if 'JJ
QUIT
SET SEGMENT(JJ-1)=$GET(@(PSJORDER_"12,"_JJ_",0)"))
+2 IF $DATA(SEGMENT(0))
SET SEGMENT(0)="NTE|6|L|"_$SELECT($GET(PSJBCBU):SEGMENT(0),1:$$ESC^ORHLESC(SEGMENT(0)))
Begin DoDot:1
+3 DO SET^PSJHLU
KILL SEGMENT,JJ
End DoDot:1
+4 ;build NTE 21 with Special Inst/Other Prt Info Wp fields *267
+5 NEW QQ
KILL ^TMP("PSJBCMA5",$JOB)
+6 DO GETSIOPI^PSJBCMA5(PSJHLDFN,RXORDER,1)
+7 IF RXORDER["V"!(RXORDER["U")
IF ($GET(PSJORD)["P")
IF ($PIECE($GET(^PS(53.1,+PSJORD,0)),"^",25)=RXORDER)
Begin DoDot:1
+8 DO GETSIOPI^PSJBCMA5(PSJHLDFN,PSJORD,1)
+9 NEW LINES,TEXT1
SET LINES=($GET(^TMP("PSJBCMA5",$JOB,PSJHLDFN,PSJORD)))
SET TEXT1=$GET(^TMP("PSJBCMA5",$JOB,PSJHLDFN,PSJORD,1))
+10 IF LINES<1!(LINES=1&(TEXT1["Instructions too long. See Order View or BCMA for full text"))
QUIT
+11 KILL ^TMP("PSJBCMA5",$JOB,PSJHLDFN,RXORDER)
MERGE ^TMP("PSJBCMA5",$JOB,PSJHLDFN,RXORDER)=^TMP("PSJBCMA5",$JOB,PSJHLDFN,PSJORD)
KILL ^TMP("PSJBCMA5",$JOB,PSJHLDFN,PSJORD)
End DoDot:1
+12 FOR QQ=0:0
SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,PSJHLDFN,RXORDER,QQ))
if 'QQ
QUIT
Begin DoDot:1
+13 IF QQ=1
Begin DoDot:2
+14 SET SEGMENT(0)="NTE|21|L|"_$$ESC^ORHLESC(^TMP("PSJBCMA5",$JOB,PSJHLDFN,RXORDER,QQ))
+15 if $GET(PSJBCBU)
SET SEGMENT(0)=SEGMENT(0)_"\.br\"
End DoDot:2
QUIT
+16 SET SEGMENT(QQ-1)=$$ESC^ORHLESC(^TMP("PSJBCMA5",$JOB,PSJHLDFN,RXORDER,QQ))
+17 if $GET(PSJBCBU)
SET SEGMENT(QQ-1)=SEGMENT(QQ-1)_"\.br\"
End DoDot:1
+18 IF $DATA(SEGMENT(0))
DO SET^PSJHLU
KILL SEGMENT,^TMP("PSJBCMA5",$JOB)
+19 ;*267 end
+20 QUIT
+21 ;
CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders
+1 ; HLEVN = number of segments in message
+2 ;*317
+3 NEW PADE,PDTYP
SET PADE=0
SET PDTYP=""
+4 IF PSJORDER["^PS(55,"
Begin DoDot:1
+5 IF $ORDER(XQORMSG(0))&((PSOC="DR")!(PSOC="OD"))
SET PADE=1
SET PDTYP=PSOC
QUIT
+6 IF '$ORDER(XQORMSG(0))
Begin DoDot:2
+7 NEW PD0,PD1
SET PD0=$GET(@(PSJORDER_"0)"))
+8 SET PD1=$SELECT(RXORDER["V":$PIECE(PD0,"^",17),1:$PIECE(PD0,"^",9))
if PD1=""
QUIT
+9 IF ",A,D,H,"[(","_$EXTRACT(PD1)_",")
SET PADE=1
SET PDTYP=PSOC
End DoDot:2
End DoDot:1
+10 ;*364 move kill PSJORDER to later for PADE
KILL CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT,%
+11 IF $GET(PSJBCBU)=1
MERGE PSJNAME=^TMP("PSJHLS",$JOB,"PS")
QUIT
+12 SET PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
+13 ;*317
IF PADE
NEW RXO,PDMSG
SET RXO=RXORDER_$SELECT(+RXORDER=RXORDER:"U",1:"")
MERGE PDMSG=^TMP("PSJHLS",$JOB,"PS")
+14 DO MSG^XQOR("PS EVSEND OR",.PSJMSG)
+15 ;*317
IF PADE
DO PDORD^PSJPDCLU
+16 IF $GET(RXORDER)
IF $GET(PSJHLDFN)
NEW PSJSTOP
SET PSJSTOP=$SELECT(RXORDER["U":$PIECE(^PS(55,PSJHLDFN,5,+RXORDER,2),"^",4),RXORDER["V":$PIECE(^PS(55,PSJHLDFN,"IV",+RXORDER,0),"^",3),1:"")
IF PSJSTOP
Begin DoDot:1
+17 NEW PSJSTATU
SET PSJSTATU=$SELECT(RXORDER["U":$PIECE(^PS(55,PSJHLDFN,5,+RXORDER,0),"^",9),RXORDER["V":$PIECE(^PS(55,PSJHLDFN,"IV",+RXORDER,0),"^",17),1:"")
+18 IF ",A,H,"[(","_PSJSTATU_",")
DO NOW^%DTC
IF PSJSTOP'>%
NEW RXON
SET RXON=RXORDER
DO EXPIR^PSJHL6
End DoDot:1
+19 ;*364 moved to here
KILL PSJORDER
+20 QUIT
+21 ;
IVTYPE(PSJORDER) ; check whether a back-door order is Inpatient IV or IV fluid
+1 IF RXORDER["V"
IF $PIECE($GET(@(PSJORDER_"0)")),"^",4)'="A"
QUIT "I"
+2 IF RXORDER["P"
IF $PIECE($GET(@(PSJORDER_"0)")),"^",4)'="F"
SET IVTYPE=""
QUIT IVTYPE
+3 NEW SUB,AD,SOL,IVTYPE,NODE1
SET SUB=0
SET IVTYPE="F"
+4 ;naked reference on line below refers to the full indirect reference of PSJORDER_ which is from ^PS(55,DFN,"IV",PSJORD
+5 FOR TYPE="AD","SOL"
SET SUB=0
FOR
SET SUB=$ORDER(@(PSJORDER_""""_TYPE_""""_","_SUB_")"))
if (SUB="")!(IVTYPE="I")
QUIT
SET NODE1=$GET(^(SUB,0))
if NODE1=""
QUIT
Begin DoDot:1
+6 IF TYPE="AD"
Begin DoDot:2
+7 IF '$PIECE($GET(^PS(52.6,$PIECE(NODE1,"^"),0)),"^",13)
SET IVTYPE="I"
End DoDot:2
+8 if TYPE="SOL"
Begin DoDot:2
+9 if '$PIECE($GET(^PS(52.7,$PIECE(NODE1,"^"),0)),"^",13)
SET IVTYPE="I"
End DoDot:2
End DoDot:1
if IVTYPE="I"
QUIT
+10 QUIT IVTYPE
ENI ;Calculate Frequency for IV orders
+1 NEW INFUSE
+2 IF X?.E1L.E
SET INFUSE=$$ENLU^PSGMI(X)
if (INFUSE="TITRATE")!(INFUSE="BOLUS")!($PIECE(INFUSE," ")="INFUSE")!($PIECE(INFUSE," ")="Infuse")
QUIT
+3 if (X="TITRATE")!(X="BOLUS")!($PIECE(X," ")="INFUSE")!($PIECE(X," ")="Infuse")
QUIT
+4 if $$INTRMT(X)
QUIT
+5 if $LENGTH(X)<1!($LENGTH(X)>30)!(X["""")!($ASCII(X)=45)
KILL X
IF '$DATA(X)
QUIT
+6 ; NOIS LOU-0501-42191
IF X["="
Begin DoDot:1
+7 NEW X2,X1
SET X1=$PIECE(X,"=")
SET X2=$PIECE(X,"=",2)
+8 IF X1["ML/HR"
IF (+X1=$PIECE(X1,"ML/HR"))!(+X1=$PIECE(X1," ML/HR"))
Begin DoDot:2
+9 SET X1=$TRANSLATE(X1,"ML/HR","ml/hr")
End DoDot:2
+10 IF X2["ML/HR"
IF (+X2=$PIECE(X2,"ML/HR"))!(+X2=$PIECE(X2," ML/HR"))
Begin DoDot:2
+11 SET X2=$TRANSLATE(X2,"ML/HR","ml/hr")
End DoDot:2
+12 IF X1[" ml/hr"
IF (+X1=$PIECE(X1," ml/hr"))
Begin DoDot:2
+13 SET X1=$PIECE(X1," ml/hr")_$PIECE(X1," ml/hr",2,9999)
End DoDot:2
+14 IF X2[" ml/hr"
IF (+X2=$PIECE(X2," ml/hr"))
Begin DoDot:2
+15 SET X2=$PIECE(X2," ml/hr")_$PIECE(X2," ml/hr",2,9999)
End DoDot:2
+16 IF X1["ml/hr"
IF (+X1=$PIECE(X1,"ml/hr"))
Begin DoDot:2
+17 SET X1=$PIECE(X1,"ml/hr")_$PIECE(X1,"ml/hr",2,9999)
End DoDot:2
+18 IF X2["ml/hr"
IF (+X2=$PIECE(X2,"ml/hr"))
Begin DoDot:2
+19 SET X2=$PIECE(X2,"ml/hr")_$PIECE(X2,"ml/hr",2,9999)
End DoDot:2
+20 IF X2'=+X2
Begin DoDot:2
+21 IF ($PIECE(X2,"@",2,999)'=+$PIECE(X2,"@",2,999)!(+$PIECE(X2,"@",2,999)<0))
KILL X
QUIT
End DoDot:2
+22 IF X1=+X1
SET X1=X1_" ml/hr"
+23 IF X2=+X2
SET X2=X2_" ml/hr"
+24 if $PIECE(X2,"@")=+X2
SET $PIECE(X2,"@")=$PIECE(X2,"@")_" ml/hr"
+25 SET X=X1_"="_X2
End DoDot:1
QUIT
+26 ;*285 - Allow for decimals with trailing zeroes
+27 IF X'?.N.1".".N
IF ($PIECE($TRANSLATE(X," ml/hr",""),"@",2,999)'=+$PIECE($TRANSLATE(X," ml/hr",""),"@",2,999)!(+$PIECE(X,"@",2,999)<0))
IF ($PIECE(X," ml/hr")'?.N.1".".N!(+$PIECE(X," ml/hr")<0))
if (X>0&($EXTRACT(X)=0))
QUIT
KILL X
QUIT
+28 ; *446 - Fix infusion rate evaluation below
+29 ; I X=+X!(X>0&($E(X)=0)) S:$S(X'["ml/hr":0,X["@":0,1:1) X=X_" ml/hr" D SPSOL S FREQ=$S('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1) K SPSOL Q
+30 IF (X=+X)!(X>0&($EXTRACT(X)=0))
SET X=$SELECT(((X'["ml/hr")&(X'["@")):X_" ml/hr",1:X)
DO SPSOL
SET FREQ=$SELECT('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1)
KILL SPSOL
QUIT
+31 ; *446 End
+32 IF X[" ml/hr"
DO SPSOL
SET FREQ=$SELECT('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1)
KILL SPSOL
QUIT
+33 SET SPSOL=$PIECE(X,"@",2)
if $PIECE(X,"@")=+X
SET $PIECE(X,"@")=$PIECE(X,"@")_" ml/hr"
SET FREQ=$SELECT('SPSOL:0,1:1440/SPSOL\1)
KILL SPSOL
+34 QUIT
SPSOL SET SPSOL=+TVOLUME
QUIT
INTRMT(X) ;
+1 if '$PIECE(X," ")
QUIT 0
+2 if $PIECE(X," ",2)="Minutes"
QUIT 1
+3 if $PIECE(X," ",2)="Hours"
QUIT 1
+4 QUIT 0
IVCAT(DFN,PSJORD,PARRAY) ; This returns the IV CATEGORY based on the IV TYPE and CHEMO TYPE (not what is already in the IV CATEGORY field)
+1 ; Passed in: PSJORDER (file root of order)
+2 NEW NODE,TYP,CHEMTYP,INTSYR,ND2P5
+3 SET (CHEMTYP,INTSYR)=""
+4 SET TYP=$GET(P(4))
SET INTSYR=$GET(P(5))
SET CHEMTYP=$GET(P(23))
+5 IF TYP=""
IF $GET(PSJORD)["V"
SET NODE=$GET(^PS(55,DFN,"IV",+PSJORD,0))
SET TYP=$PIECE(NODE,"^",4)
SET INTSYR=$PIECE(NODE,"^",5)
SET CHEMTYP=$PIECE(NODE,"^",23)
+6 IF TYP=""
IF $GET(PSJORD)["P"
SET NODE=$GET(^PS(53.1,+PSJORD,8))
SET TYP=$PIECE(NODE,"^")
SET INTSYR=$PIECE(NODE,"^",4)
SET CHEMTYP=$PIECE(NODE,"^",2)
+7 IF TYP=""
SET TYP=$GET(PARRAY(4))
SET INTSYR=$GET(PARRAY(5))
SET CHEMTYP=$GET(PARRAY(23))
+8 if $GET(TYP)=""
QUIT ""
+9 SET CAT=$SELECT(",A,H,"[(","_TYP_","):"C",TYP="C"&(",A,H,S,"[(","_CHEMTYP_",")&'INTSYR):"C",TYP="C"&(CHEMTYP="P"):"I",TYP="S"&'INTSYR:"C",TYP="P":"I",$GET(INTSYR):"I",1:"")
+10 QUIT CAT
ZRX ; Perform outbound processing
+1 NEW NODE1
+2 SET NODE1=$GET(@(PSJORDER_"0)"))
+3 SET LIMIT=6
XECUTE PSJCLEAR
+4 SET FIELD(0)="ZRX"
+5 IF '$GET(PSJREN)
NEW PREON,PSJREN
IF $GET(PSJORD)["U"&($PIECE(NODE1,"^",24)="R")
SET PSJREN=1
+6 IF $GET(PSJORD)["V"&($PIECE(NODE2,"^",8)="R")
SET PSJREN=1
+7 SET PREON=$SELECT($GET(PSJREN):$GET(PSJORD),PSJORDER["IV":$PIECE(NODE2,"^",5),1:$PIECE(NODE1,"^",25))
+8 SET FIELD(1)=$SELECT(PREON["P":$PIECE($GET(^PS(53.1,+PREON,0)),"^",21),PREON["V":$PIECE($GET(^PS(55,PSJHLDFN,"IV",+PREON,0)),"^",21),1:$PIECE($GET(^PS(55,PSJHLDFN,5,+PREON,0)),"^",21))
+9 SET FIELD(2)=$SELECT(PSJORDER["IV":$GET(P("NAT")),1:$GET(PSJNOO))
+10 SET FIELD(3)=$SELECT($GET(PSJREN):"R",PSJORDER["IV":$PIECE(NODE2,"^",8),1:$PIECE(NODE1,"^",24))
+11 IF FIELD(3)=""
IF PSOC="SN"
SET FIELD(3)="N"
+12 IF $DATA(P)>1
SET FIELD(6)=$$IVCAT^PSJHLU(PSJHLDFN,RXORDER,.P)
+13 SET NAME=$PIECE($GET(^VA(200,DUZ,0)),"^")
+14 SET FIELD(5)=DUZ_"^"_$SELECT($GET(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))_"^"_"99NP"
+15 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY^PSJHL2
+16 QUIT
+17 ;
ZZZ ; BCBU ZZZ Seg, Hazardous drug flags ZZZ.4 & ZZZ.5 *364
+1 NEW NODE1,HAZ
+2 SET NODE1=$GET(@(PSJORDER_"0)"))
+3 SET LIMIT=5
XECUTE PSJCLEAR
+4 SET FIELD(0)="ZZZ"
+5 ;Field(1-3) below, not used for BCBU reserved for PADE in PSJPDCLU
+6 SET FIELD(1)=""
+7 SET FIELD(2)=""
+8 SET FIELD(3)=""
+9 ;get Haz flag 1 or 0 value and convert flags to HL7 Y or N values
SET HAZ=$$HAZDRUG(PSJORDER)
+10 SET FIELD(4)=$SELECT($PIECE(HAZ,U):"Y",1:"N")
+11 SET FIELD(5)=$SELECT($PIECE(HAZ,U,2):"Y",1:"N")
+12 ;set fields into segment temp global
+13 DO SEGMENT^PSJHLU(LIMIT)
DO DISPLAY^PSJHL2
+14 QUIT
+15 ;
HAZDRUG(FILE) ;Get Hazardous to Handle and Hazardous to Dispose fields per this order (if any component is Haz then order is) *364
+1 ; FILE = file root + Order Num from inpatient variables during workflow; Example VAR contains: "^PS(55,DFN,5,ON," or "(PS(53.1,ON," or "^PS(55,DFN,"IV",ON,"
+2 ; (build ROOT to the multiple level to find all Disp Drugs or Additives or Solution and check for any HAZ components.)
+3 NEW QQ,ROOT,NXTROOT,NXT,IFN,GL,HAZH,HAZD,HZIFN
+4 SET (HAZH,HAZD,HZIFN)=0
+5 ;check IF Unit Dose Disp Drug exists this order, then get IEN and Haz flags
+6 FOR QQ=0:0
SET ROOT=FILE_"1,"_QQ_")"
SET QQ=$ORDER(@ROOT)
if 'QQ
QUIT
Begin DoDot:1
+7 SET NXTROOT=FILE_"1,"_QQ_")"
SET NXT=$ORDER(@NXTROOT)
SET GL=$EXTRACT(NXTROOT,1,$LENGTH(ROOT)-1)
SET IFN=+@(GL_",0)")
+8 if $PIECE($$HAZ^PSSUTIL(IFN),U,1)
SET HAZH=1
SET HZIFN=IFN
+9 if $PIECE($$HAZ^PSSUTIL(IFN),U,2)
SET HAZD=1
SET HZIFN=IFN
+10 ;check IF IV additives exists this order, then get IEN and Haz flags
End DoDot:1
+11 FOR QQ=0:0
SET ROOT=FILE_"""AD"","_QQ_")"
SET QQ=$ORDER(@ROOT)
if 'QQ
QUIT
Begin DoDot:1
+12 SET NXTROOT=FILE_"""AD"","_QQ_")"
SET NXT=$ORDER(@NXTROOT)
SET GL=$EXTRACT(NXTROOT,1,$LENGTH(ROOT)-1)
SET IFN=+@(GL_",0)")
+13 if IFN
SET IFN=+$PIECE($GET(^PS(52.6,IFN,0)),U,2)
+14 if $PIECE($$HAZ^PSSUTIL(IFN),U,1)
SET HAZH=1
SET HZIFN=IFN
+15 if $PIECE($$HAZ^PSSUTIL(IFN),U,2)
SET HAZD=1
SET HZIFN=IFN
End DoDot:1
+16 FOR QQ=0:0
SET ROOT=FILE_"""SOL"","_QQ_")"
SET QQ=$ORDER(@ROOT)
if 'QQ
QUIT
Begin DoDot:1
+17 SET NXTROOT=FILE_"""SOL"","_QQ_")"
SET NXT=$ORDER(@NXTROOT)
SET GL=$EXTRACT(NXTROOT,1,$LENGTH(ROOT)-1)
SET IFN=+@(GL_",0)")
+18 if IFN
SET IFN=+$PIECE($GET(^PS(52.7,IFN,0)),U,2)
+19 if $PIECE($$HAZ^PSSUTIL(IFN),U,1)
SET HAZH=1
SET HZIFN=IFN
+20 if $PIECE($$HAZ^PSSUTIL(IFN),U,2)
SET HAZD=1
SET HZIFN=IFN
End DoDot:1
+21 QUIT HAZH_U_HAZD_U_HZIFN
