- PSJHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM
- ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102,134**;16 DEC 97;Build 124
- ;
- ; 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.
- ;
- 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
- I $P($G(@(PSJORDER_"6)")),"^")]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"6)")),"^"),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"6)")),"^"))) D
- .D SET^PSJHLU K SEGMENT
- I PSJORDER["P",$P($G(@(PSJORDER_"9)")),"^",2)]"" K SEGMENT S SEGMENT(0)="NTE|21|L|"_$S($G(PSJBCBU):$P($G(@(PSJORDER_"9)")),"^",2),1:$$ESC^ORHLESC($P($G(@(PSJORDER_"9)")),"^",2))) D
- .D SET^PSJHLU K SEGMENT
- Q
- ;
- CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders
- ; HLEVN = number of segments in message
- K CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT
- I $G(PSJBCBU)=1 M PSJNAME=^TMP("PSJHLS",$J,"PS") Q
- S PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
- D MSG^XQOR("PS EVSEND OR",.PSJMSG)
- 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
- I X'=+X,($P($TR(X," ml/hr",""),"@",2,999)'=+$P($TR(X," ml/hr",""),"@",2,999)!(+$P(X,"@",2,999)<0)),($P(X," ml/hr")'=+$P(X," ml/hr")!(+$P(X," ml/hr")<0)) Q:(X>0&($E(X)=0)) K X Q
- I X=+X!(X>0&($E(X)=0)) S 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[" 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
- 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
- PSJHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;20 Apr 98 / 9:58 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**1,56,72,102,134**;16 DEC 97;Build 124
- +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 ;
- 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 IF $PIECE($GET(@(PSJORDER_"6)")),"^")]""
- KILL SEGMENT
- SET SEGMENT(0)="NTE|21|L|"_$SELECT($GET(PSJBCBU):$PIECE($GET(@(PSJORDER_"6)")),"^"),1:$$ESC^ORHLESC($PIECE($GET(@(PSJORDER_"6)")),"^")))
- Begin DoDot:1
- +5 DO SET^PSJHLU
- KILL SEGMENT
- End DoDot:1
- +6 IF PSJORDER["P"
- IF $PIECE($GET(@(PSJORDER_"9)")),"^",2)]""
- KILL SEGMENT
- SET SEGMENT(0)="NTE|21|L|"_$SELECT($GET(PSJBCBU):$PIECE($GET(@(PSJORDER_"9)")),"^",2),1:$$ESC^ORHLESC($PIECE($GET(@(PSJORDER_"9)")),"^",2)))
- Begin DoDot:1
- +7 DO SET^PSJHLU
- KILL SEGMENT
- End DoDot:1
- +8 QUIT
- +9 ;
- CALL(HLEVN) ; call DHCP HL7 package -or- protocol, to pass Orders
- +1 ; HLEVN = number of segments in message
- +2 KILL CLERK,DDIEN,DDNUM,DOSEFORM,DOSEOR,FIELD,IVTYPE,LIMIT,NAME,NDNODE,NODE1,NODE2,PRODNAME,PROVIDER,PSGS0Y,PSJHINST,PSJHLSDT,PSJI,PSJORDER,PSOC,PSREASON,ROOMBED,SPDIEN,SEGMENT
- +3 IF $GET(PSJBCBU)=1
- MERGE PSJNAME=^TMP("PSJHLS",$JOB,"PS")
- QUIT
- +4 SET PSJMSG="^TMP(""PSJHLS"",$J,""PS"")"
- +5 DO MSG^XQOR("PS EVSEND OR",.PSJMSG)
- +6 QUIT
- +7 ;
- 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 IF X'=+X
- 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")'=+$PIECE(X," ml/hr")!(+$PIECE(X," ml/hr")<0))
- IF (X>0&($EXTRACT(X)=0))
- QUIT
- KILL X
- QUIT
- +27 IF X=+X!(X>0&($EXTRACT(X)=0))
- SET X=X_" ml/hr"
- DO SPSOL
- SET FREQ=$SELECT('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1)
- KILL SPSOL
- QUIT
- +28 IF X[" ml/hr"
- DO SPSOL
- SET FREQ=$SELECT('X:0,1:SPSOL\X*60+(SPSOL#X/X*60+.5)\1)
- KILL SPSOL
- QUIT
- +29 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
- +30 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 SET LIMIT=6
- XECUTE PSJCLEAR
- +2 SET FIELD(0)="ZRX"
- +3 IF '$GET(PSJREN)
- NEW PREON,PSJREN
- IF $GET(PSJORD)["U"&($PIECE(NODE1,"^",24)="R")
- SET PSJREN=1
- +4 IF $GET(PSJORD)["V"&($PIECE(NODE2,"^",8)="R")
- SET PSJREN=1
- +5 SET PREON=$SELECT($GET(PSJREN):$GET(PSJORD),PSJORDER["IV":$PIECE(NODE2,"^",5),1:$PIECE(NODE1,"^",25))
- +6 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))
- +7 SET FIELD(2)=$SELECT(PSJORDER["IV":$GET(P("NAT")),1:$GET(PSJNOO))
- +8 SET FIELD(3)=$SELECT($GET(PSJREN):"R",PSJORDER["IV":$PIECE(NODE2,"^",8),1:$PIECE(NODE1,"^",24))
- +9 IF FIELD(3)=""
- IF PSOC="SN"
- SET FIELD(3)="N"
- +10 IF $DATA(P)>1
- SET FIELD(6)=$$IVCAT^PSJHLU(PSJHLDFN,RXORDER,.P)
- +11 SET NAME=$PIECE($GET(^VA(200,DUZ,0)),"^")
- +12 SET FIELD(5)=DUZ_"^"_$SELECT($GET(PSJBCBU):NAME,1:$$ESC^ORHLESC(NAME))_"^"_"99NP"
- +13 DO SEGMENT^PSJHLU(LIMIT)
- DO DISPLAY^PSJHL2
- +14 QUIT