ORMBLDVB ;SLC/MKB - Build outgoing Blood Bank ORM msgs ;2/11/08 11:04
;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309**;Dec 17, 1997;Build 26
;
; Use of $$GETICN^MPIF001 supported by DBIA #2701
;
HL7DATE(DATE) ; -- FM -> HL7 format
Q $$FMTHL7^XLFDT(DATE)
;
NW(ORIFN) ; -- Send new VBECS orders [from ORCSEND2]
; Uses ORNOW if defined
N HLA,HL,OR0,OR3,ORR,ORDT,ORVAL,ORI,OROK,HLMTIEN
S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3))
D INIT^HLFNC2("OR OMG SERVER",.HL),GETVALS(ORIFN)
S ORDT=$S($G(ORNOW):ORNOW,1:+$E($$NOW^XLFDT,1,12))
S ORR=$G(ORVAL("REASON")),ORDT=$$HL7DATE(ORDT)
;S ORMSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|VBECS|"_$G(DUZ(2))_"|"_ORDT_"||OMG^O19||P|2.4||||AL" ;for testing
S HLA("HLS",1)=$$PID(+$P(OR0,U,2)),HLA("HLS",2)=$$PV1
S HLA("HLS",3)=$$ORC("NW","",ORR),HLA("HLS",4)=$$OBR(""),ORI=4
S:$L($G(ORVAL("COMMENT"))) HLA("HLS",5)=$$NTE,ORI=5
S ORI=ORI+1,HLA("HLS",ORI)=$$DG1(+$P(OR0,U,2))
;W ! ZW HLA D STATUS^ORCSAVE2(ORIFN,5) ;for testing
D DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK)
I $P(OROK,U,2) D SNDERR($P(OROK,U,3)),GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK) Q ;queue
; S ^OR(100,ORIFN,8,1,1)=$P(OROK,U,3),$P(^(0),U,15)=13 Q
I HLMTIEN D ACK^ORMVBEC(+ORIFN_";1") ;successful, process ACK message
Q
;
GETVALS(IFN) ; -- Return ORVAL(ID)=value for child order IFN
N ID,ITM S ID="" K ORVAL
F S ID=$O(^OR(100,IFN,4.5,"ID",ID)) Q:ID="" S ITM=$O(^(ID,0)),ORVAL(ID)=$G(^OR(100,IFN,4.5,ITM,1))
Q
;
RESULTS(ORDER) ; -- Send PR messages with Lab results [from EN]
; where ORDER = parent#
N ORP,ORI,ORTST,ORTMP,ORTDT,ORX,OROK,HLA
S ORDER=+$G(ORDER),OR0=$G(^OR(100,ORDER,0)),ORI=0
F S ORI=$O(^OR(100,ORDER,4.5,"ID","RESULTS",ORI)) Q:ORI<1 D
. S ORX=$G(^OR(100,ORDER,4.5,ORI,1)),ORTDT=$P(ORX,U,7)
. Q:'ORX ;no data or error
. S ORTST=+ORX_U_$P($G(^LAB(60,+ORX,0)),U) K HLA,OROK
. S HLA("HLS",1)=$$PID(+$P(OR0,U,2)),HLA("HLS",2)=$$PV1
. S HLA("HLS",3)="ORC|PR|||"_ORDER_"^OR"
. S HLA("HLS",4)="OBR||"_$P(ORX,U,17)_"^LRCH||"_ORTST_"^99LRT"
. S HLA("HLS",5)="OBX|1||"_ORTST_"^99LRT||"_$P(ORX,U,2)_"|"_$P(ORX,U,4)_"|"_$P(ORX,U,5)_"|"_$P(ORX,U,3)_"|||"_$P(ORX,U,6)_"|||"_$$HL7DATE(ORTDT)
. ;W ! ZW HLA ;for testing
. D DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK) ;GENERATE
. I $P(OROK,U,2) D SNDERR($P(OROK,U,3)),GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK) Q ;queue
.
Q
;
CA(ORDER,REASON) ; -- Cancel VBEC orders (ORDER=child)
; [from DC^ORCSEND/MSG^ORMBLD - Uses ORNOW if defined]
N ORIFN,ORDA,ORDT,OR0,OR3,PKGIFN,HL,HLA,ORVAL,OROK,HLMTIEN
S ORDT=$S($G(ORNOW):ORNOW,1:+$E($$NOW^XLFDT,1,12))
S ORIFN=+$G(ORDER),ORDA=+$P($G(ORDER),";",2),ORDT=$$HL7DATE(ORDT)
S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)),PKGIFN=$G(^(4))_"^VBEC"
S REASON=$S($G(REASON):$P($G(^ORD(100.03,+REASON,0)),U),1:"")
D INIT^HLFNC2("OR OMG SERVER",.HL),GETVALS(ORIFN)
;S ORMSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|VBECS|"_$G(DUZ(2))_"|"_ORDT_"||OMG^O19||P|2.4||||AL" ;for now
S HLA("HLS",1)=$$PID(+$P(OR0,U,2)),HLA("HLS",2)=$$PV1
S HLA("HLS",3)=$$ORC("CA",PKGIFN,REASON),HLA("HLS",4)=$$OBR(PKGIFN)
D DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK) ;GENERATE^HLMA
I $P(OROK,U,2) D Q
. S:ORDA ^OR(100,ORIFN,8,ORDA,1)=$P(OROK,U,3),$P(^(0),U,15)=13
. D SNDERR($P(OROK,U,3)),GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK) Q
I HLMTIEN D ACK^ORMVBEC(ORDER) ;successful, process ACK message
Q
;
SNDERR(MSG) ; -- Send Error message to VBECS Mail Group
; Input - MSG = Error message string
N OREMSG,XMSUB,XMTEXT,XMDUZ,XMY,XMZ
S OREMSG(1,0)="An Error occurred trying to send an HL7 message to VBECS."
S OREMSG(2,0)=" "
S OREMSG(3,0)="Error Message Text: "_$S($L(MSG)>60:$E(MSG,1,60),1:MSG)
S XMY("G."_$P($$GETAPP^HLCS2("VBECS"),"^"))=""
S XMTEXT="OREMSG(",XMSUB="OERR-VBECS HL7 Failure",XMDUZ="OERR-VBECS Logical Link" D XMZ^XMA2
S DIE=3.9,DA=XMZ,DR="1.7////P" D ^DIE
D EN1^XMD
Q
;
PID(DFN) ; -- PID segment
N ORPT0,ORICN,NAME,DOB,Y S DFN=+$G(DFN)
S ORPT0=$G(^DPT(DFN,0))
S ORICN=$$GETICN^MPIF001(DFN) I +$G(ORICN)<1 S ORICN=""
S NAME=$$HLNAME^HLFNC($P(ORPT0,U),"^~\&"),DOB=$$HL7DATE($P(ORPT0,U,3))
S Y="PID|||"_ORICN_"^^^^NI~"_$P(ORPT0,U,9)_"^^^^SS~"_DFN_"^^^^PI||"_NAME_"||"_DOB_"|"_$P(ORPT0,U,2)
Q Y
;
PV1() ; -- PV1 segment (expects OR0)
N Y,DFN,LOC,TYPE,SPEC,RB,ATTD
S DFN=+$P(OR0,U,2),LOC=$P(OR0,U,10),TYPE=$P(OR0,U,12),SPEC=$P(OR0,U,13)
S LOC=$S(LOC:$P($G(^SC(+LOC,0)),U),1:""),RB=""
S:TYPE="I" RB=$P($G(^DPT(DFN,.101)),U)
S SPEC=$S(SPEC:"VA"_$$GET1^DIQ(45.7,SPEC_",",1,"I"),1:"") ;DBIA 1154
S ATTD=+$G(^DPT(DFN,.1041)) S:'ATTD ATTD="" I ATTD D ;DBIA 10035
. N NM S NM=$P($G(^VA(200,ATTD,0)),U)
. S ATTD=ATTD_U_$$HLNAME^HLFNC(NM,"^~\&")
S Y="PV1||"_TYPE_"|"_LOC_$S($L(RB):U_RB,1:"")_"||||"_ATTD_"|||"_SPEC
Q Y
;
ORC(CODE,FILLER,REASON) ; -- ORC segment (expects OR0, OR3, ORDT)
N Y,USR,PROV,NM,ORI,DAD,YN,X13,PHONE
S USR=+$P(OR0,U,6),PROV=+$P(OR0,U,4),X13=$G(^VA(200,PROV,.13))
S PHONE=$S($L($P(X13,U,7)):$P(X13,U,7),1:$P(X13,U,8))
F ORI="USR","PROV" S NM=$P($G(^VA(200,@ORI,0)),U),@ORI=@ORI_U_$$HLNAME^HLFNC(NM,"^~\&")
S DAD=+$P(OR3,U,9) ;,DIV=$$DIV(+$P(OR0,U,10))
S Y="ORC|"_CODE_"|"_ORIFN_"^OR|"_$G(FILLER)_"|"_DAD_"^OR|||||"_ORDT_"|"_USR_"||"_PROV_"||"_PHONE_"||^"_$G(REASON)_"|"_$$DIV
S YN=$G(ORVAL("YN")),YN=$S(YN="":"",YN:"1^YES",YN=0:"0^NO",1:"U^UNKNOWN")
S Y=Y_"|||"_YN
Q Y
;
OBR(FILLER) ; -- OBR segment
N Y,OI,MOD,TYPE,X,SPCACT,SPCUID
S OI=$$USID(ORIFN),MOD=$G(ORVAL("MODIFIER"))
I $L(MOD) S MOD=$S(MOD="W":"WASHED",MOD="I":"IRRADIATED",MOD="L":"LEUKO-POOR",MOD="V":"VOLUME-REDUCED",MOD="D":"DIVIDED",MOD="E":"LEUKO-POOR/IRRADIATED",1:MOD)
S TYPE=$G(ORVAL("COLLECT")),TYPE=$$TYPE(TYPE)
S X=$G(ORVAL("SPECSTS")),SPCACT=$S('X:"O",$L($P(X,U,3)):"A",1:"L")
S SPCUID=$S(SPCACT="A":$P(X,U,3),1:"")
S Y="OBR|1|"_ORIFN_"^OR|"_$G(FILLER)_"|"_OI_"^^"_MOD_"|||||||"_SPCACT_"||"_$G(ORLAB)_"||"_SPCUID_"^^"_TYPE_"||||||||||||"_$$QT
Q Y
;
USID(IFN) ; -- Return USID for order IFN
N OI,OI0,OID,OIX,Y S Y=""
S OI=+$O(^OR(100,+$G(IFN),.1,"B",0)) I OI D
. S OI0=$G(^ORD(101.43,OI,0)),OID=$P(OI0,U,2)
. S OIX=$P(OI0,U,8) I OIX["&" S OIX=$P(OIX,"&")_"\T\"_$P(OIX,"&",2)
. S Y=+OID_U_OIX_U_$P(OID,";",2)
Q Y
;
NTE() ; -- NTE segment
N Y S Y="NTE|1||"_$G(ORVAL("COMMENT"))
Q Y
;
DG1(DFN) ; -- DG1 segment
N VAIP,VAERR,Y
S DFN=+$G(DFN) D IN5^VADPT
S Y="DG1|1||^^^^"_$G(VAIP(9))_"^|||A"
Q Y
;
QT() ; -- Build and return Quantity/Timing field
N X,Y,%DT,X1,X4,X5,X6,X8,ORI
S X=$G(ORVAL("QTY")),X1=$S(X:+X_$S(X["ML":"&ML",1:""),1:"")
S (X4,X5)="" F ORI="START^4","DATETIME^5" D
. S X=$G(ORVAL($P(ORI,U))),%DT="TX" D ^%DT Q:Y<1
. S X=$$HL7DATE(Y),@("X"_$P(ORI,U,2))=X
S X=$G(ORVAL("URGENCY")),X6=$P($G(^ORD(101.42,+X,0)),U,2)
;S X=$G(ORVAL("XFUSION")),X7=$S(X="H":"HOLD",X="I":"IMMEDIATE",1:"")
S X8=$G(ORVAL("MISC"))
S Y=X1_U_U_U_X4_U_X5_U_X6_U_U_X8
Q Y
;
DIV() ; -- Return Institution file #4 ptr for LOC
N X,Y S X=+$G(DUZ(2))
S Y=$P($G(^DIC(4,X,99)),U)_U_$P($G(^DIC(4,X,0)),U)
Q Y
;
ZDIV(LOC) ; -- Return Institution file #4 ptr for LOC
N X0,Y S X0=$G(^SC(+LOC,0))
I $P(X0,U,15) S X=$$SITE^VASITE(DT,$P(X0,U,15)),Y=$P(X,U,3)_U_$P(X,U,2)
I '$P(X0,U,15) S X=$S($P(X0,U,4):$P(X0,U,4),1:+$G(DUZ(2))),Y=X_U_$P($G(^DIC(4,+X,0)),U) ;look up #40.8 ptr??
Q Y
;
TYPE(X) ; -- Expands collection type code into text
Q:'$L($G(X)) ""
I X="SP" Q "SEND PATIENT"
S X=$E(X),X=$S(X="L":"LAB",X="I":"IMMEDIATE",1:"WARD")
Q X_" COLLECT"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMBLDVB 7491 printed Dec 13, 2024@02:31:52 Page 2
ORMBLDVB ;SLC/MKB - Build outgoing Blood Bank ORM msgs ;2/11/08 11:04
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309**;Dec 17, 1997;Build 26
+2 ;
+3 ; Use of $$GETICN^MPIF001 supported by DBIA #2701
+4 ;
HL7DATE(DATE) ; -- FM -> HL7 format
+1 QUIT $$FMTHL7^XLFDT(DATE)
+2 ;
NW(ORIFN) ; -- Send new VBECS orders [from ORCSEND2]
+1 ; Uses ORNOW if defined
+2 NEW HLA,HL,OR0,OR3,ORR,ORDT,ORVAL,ORI,OROK,HLMTIEN
+3 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
+4 DO INIT^HLFNC2("OR OMG SERVER",.HL)
DO GETVALS(ORIFN)
+5 SET ORDT=$SELECT($GET(ORNOW):ORNOW,1:+$EXTRACT($$NOW^XLFDT,1,12))
+6 SET ORR=$GET(ORVAL("REASON"))
SET ORDT=$$HL7DATE(ORDT)
+7 ;S ORMSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|VBECS|"_$G(DUZ(2))_"|"_ORDT_"||OMG^O19||P|2.4||||AL" ;for testing
+8 SET HLA("HLS",1)=$$PID(+$PIECE(OR0,U,2))
SET HLA("HLS",2)=$$PV1
+9 SET HLA("HLS",3)=$$ORC("NW","",ORR)
SET HLA("HLS",4)=$$OBR("")
SET ORI=4
+10 if $LENGTH($GET(ORVAL("COMMENT")))
SET HLA("HLS",5)=$$NTE
SET ORI=5
+11 SET ORI=ORI+1
SET HLA("HLS",ORI)=$$DG1(+$PIECE(OR0,U,2))
+12 ;W ! ZW HLA D STATUS^ORCSAVE2(ORIFN,5) ;for testing
+13 DO DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK)
+14 ;queue
IF $PIECE(OROK,U,2)
DO SNDERR($PIECE(OROK,U,3))
DO GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK)
QUIT
+15 ; S ^OR(100,ORIFN,8,1,1)=$P(OROK,U,3),$P(^(0),U,15)=13 Q
+16 ;successful, process ACK message
IF HLMTIEN
DO ACK^ORMVBEC(+ORIFN_";1")
+17 QUIT
+18 ;
GETVALS(IFN) ; -- Return ORVAL(ID)=value for child order IFN
+1 NEW ID,ITM
SET ID=""
KILL ORVAL
+2 FOR
SET ID=$ORDER(^OR(100,IFN,4.5,"ID",ID))
if ID=""
QUIT
SET ITM=$ORDER(^(ID,0))
SET ORVAL(ID)=$GET(^OR(100,IFN,4.5,ITM,1))
+3 QUIT
+4 ;
RESULTS(ORDER) ; -- Send PR messages with Lab results [from EN]
+1 ; where ORDER = parent#
+2 NEW ORP,ORI,ORTST,ORTMP,ORTDT,ORX,OROK,HLA
+3 SET ORDER=+$GET(ORDER)
SET OR0=$GET(^OR(100,ORDER,0))
SET ORI=0
+4 FOR
SET ORI=$ORDER(^OR(100,ORDER,4.5,"ID","RESULTS",ORI))
if ORI<1
QUIT
Begin DoDot:1
+5 SET ORX=$GET(^OR(100,ORDER,4.5,ORI,1))
SET ORTDT=$PIECE(ORX,U,7)
+6 ;no data or error
if 'ORX
QUIT
+7 SET ORTST=+ORX_U_$PIECE($GET(^LAB(60,+ORX,0)),U)
KILL HLA,OROK
+8 SET HLA("HLS",1)=$$PID(+$PIECE(OR0,U,2))
SET HLA("HLS",2)=$$PV1
+9 SET HLA("HLS",3)="ORC|PR|||"_ORDER_"^OR"
+10 SET HLA("HLS",4)="OBR||"_$PIECE(ORX,U,17)_"^LRCH||"_ORTST_"^99LRT"
+11 SET HLA("HLS",5)="OBX|1||"_ORTST_"^99LRT||"_$PIECE(ORX,U,2)_"|"_$PIECE(ORX,U,4)_"|"_$PIECE(ORX,U,5)_"|"_$PIECE(ORX,U,3)_"|||"_$PIECE(ORX,U,6)_"|||"_$$HL7DATE(ORTDT)
+12 ;W ! ZW HLA ;for testing
+13 ;GENERATE
DO DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK)
+14 ;queue
IF $PIECE(OROK,U,2)
DO SNDERR($PIECE(OROK,U,3))
DO GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK)
QUIT
+15 End DoDot:1
+16 QUIT
+17 ;
CA(ORDER,REASON) ; -- Cancel VBEC orders (ORDER=child)
+1 ; [from DC^ORCSEND/MSG^ORMBLD - Uses ORNOW if defined]
+2 NEW ORIFN,ORDA,ORDT,OR0,OR3,PKGIFN,HL,HLA,ORVAL,OROK,HLMTIEN
+3 SET ORDT=$SELECT($GET(ORNOW):ORNOW,1:+$EXTRACT($$NOW^XLFDT,1,12))
+4 SET ORIFN=+$GET(ORDER)
SET ORDA=+$PIECE($GET(ORDER),";",2)
SET ORDT=$$HL7DATE(ORDT)
+5 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
SET PKGIFN=$GET(^(4))_"^VBEC"
+6 SET REASON=$SELECT($GET(REASON):$PIECE($GET(^ORD(100.03,+REASON,0)),U),1:"")
+7 DO INIT^HLFNC2("OR OMG SERVER",.HL)
DO GETVALS(ORIFN)
+8 ;S ORMSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|VBECS|"_$G(DUZ(2))_"|"_ORDT_"||OMG^O19||P|2.4||||AL" ;for now
+9 SET HLA("HLS",1)=$$PID(+$PIECE(OR0,U,2))
SET HLA("HLS",2)=$$PV1
+10 SET HLA("HLS",3)=$$ORC("CA",PKGIFN,REASON)
SET HLA("HLS",4)=$$OBR(PKGIFN)
+11 ;GENERATE^HLMA
DO DIRECT^HLMA("OR OMG SERVER","LM",1,.OROK)
+12 IF $PIECE(OROK,U,2)
Begin DoDot:1
+13 if ORDA
SET ^OR(100,ORIFN,8,ORDA,1)=$PIECE(OROK,U,3)
SET $PIECE(^(0),U,15)=13
+14 DO SNDERR($PIECE(OROK,U,3))
DO GENERATE^HLMA("OR OMG SERVER","LM",1,.OROK)
QUIT
End DoDot:1
QUIT
+15 ;successful, process ACK message
IF HLMTIEN
DO ACK^ORMVBEC(ORDER)
+16 QUIT
+17 ;
SNDERR(MSG) ; -- Send Error message to VBECS Mail Group
+1 ; Input - MSG = Error message string
+2 NEW OREMSG,XMSUB,XMTEXT,XMDUZ,XMY,XMZ
+3 SET OREMSG(1,0)="An Error occurred trying to send an HL7 message to VBECS."
+4 SET OREMSG(2,0)=" "
+5 SET OREMSG(3,0)="Error Message Text: "_$SELECT($LENGTH(MSG)>60:$EXTRACT(MSG,1,60),1:MSG)
+6 SET XMY("G."_$PIECE($$GETAPP^HLCS2("VBECS"),"^"))=""
+7 SET XMTEXT="OREMSG("
SET XMSUB="OERR-VBECS HL7 Failure"
SET XMDUZ="OERR-VBECS Logical Link"
DO XMZ^XMA2
+8 SET DIE=3.9
SET DA=XMZ
SET DR="1.7////P"
DO ^DIE
+9 DO EN1^XMD
+10 QUIT
+11 ;
PID(DFN) ; -- PID segment
+1 NEW ORPT0,ORICN,NAME,DOB,Y
SET DFN=+$GET(DFN)
+2 SET ORPT0=$GET(^DPT(DFN,0))
+3 SET ORICN=$$GETICN^MPIF001(DFN)
IF +$GET(ORICN)<1
SET ORICN=""
+4 SET NAME=$$HLNAME^HLFNC($PIECE(ORPT0,U),"^~\&")
SET DOB=$$HL7DATE($PIECE(ORPT0,U,3))
+5 SET Y="PID|||"_ORICN_"^^^^NI~"_$PIECE(ORPT0,U,9)_"^^^^SS~"_DFN_"^^^^PI||"_NAME_"||"_DOB_"|"_$PIECE(ORPT0,U,2)
+6 QUIT Y
+7 ;
PV1() ; -- PV1 segment (expects OR0)
+1 NEW Y,DFN,LOC,TYPE,SPEC,RB,ATTD
+2 SET DFN=+$PIECE(OR0,U,2)
SET LOC=$PIECE(OR0,U,10)
SET TYPE=$PIECE(OR0,U,12)
SET SPEC=$PIECE(OR0,U,13)
+3 SET LOC=$SELECT(LOC:$PIECE($GET(^SC(+LOC,0)),U),1:"")
SET RB=""
+4 if TYPE="I"
SET RB=$PIECE($GET(^DPT(DFN,.101)),U)
+5 ;DBIA 1154
SET SPEC=$SELECT(SPEC:"VA"_$$GET1^DIQ(45.7,SPEC_",",1,"I"),1:"")
+6 ;DBIA 10035
SET ATTD=+$GET(^DPT(DFN,.1041))
if 'ATTD
SET ATTD=""
IF ATTD
Begin DoDot:1
+7 NEW NM
SET NM=$PIECE($GET(^VA(200,ATTD,0)),U)
+8 SET ATTD=ATTD_U_$$HLNAME^HLFNC(NM,"^~\&")
End DoDot:1
+9 SET Y="PV1||"_TYPE_"|"_LOC_$SELECT($LENGTH(RB):U_RB,1:"")_"||||"_ATTD_"|||"_SPEC
+10 QUIT Y
+11 ;
ORC(CODE,FILLER,REASON) ; -- ORC segment (expects OR0, OR3, ORDT)
+1 NEW Y,USR,PROV,NM,ORI,DAD,YN,X13,PHONE
+2 SET USR=+$PIECE(OR0,U,6)
SET PROV=+$PIECE(OR0,U,4)
SET X13=$GET(^VA(200,PROV,.13))
+3 SET PHONE=$SELECT($LENGTH($PIECE(X13,U,7)):$PIECE(X13,U,7),1:$PIECE(X13,U,8))
+4 FOR ORI="USR","PROV"
SET NM=$PIECE($GET(^VA(200,@ORI,0)),U)
SET @ORI=@ORI_U_$$HLNAME^HLFNC(NM,"^~\&")
+5 ;,DIV=$$DIV(+$P(OR0,U,10))
SET DAD=+$PIECE(OR3,U,9)
+6 SET Y="ORC|"_CODE_"|"_ORIFN_"^OR|"_$GET(FILLER)_"|"_DAD_"^OR|||||"_ORDT_"|"_USR_"||"_PROV_"||"_PHONE_"||^"_$GET(REASON)_"|"_$$DIV
+7 SET YN=$GET(ORVAL("YN"))
SET YN=$SELECT(YN="":"",YN:"1^YES",YN=0:"0^NO",1:"U^UNKNOWN")
+8 SET Y=Y_"|||"_YN
+9 QUIT Y
+10 ;
OBR(FILLER) ; -- OBR segment
+1 NEW Y,OI,MOD,TYPE,X,SPCACT,SPCUID
+2 SET OI=$$USID(ORIFN)
SET MOD=$GET(ORVAL("MODIFIER"))
+3 IF $LENGTH(MOD)
SET MOD=$SELECT(MOD="W":"WASHED",MOD="I":"IRRADIATED",MOD="L":"LEUKO-POOR",MOD="V":"VOLUME-REDUCED",MOD="D":"DIVIDED",MOD="E":"LEUKO-POOR/IRRADIATED",1:MOD)
+4 SET TYPE=$GET(ORVAL("COLLECT"))
SET TYPE=$$TYPE(TYPE)
+5 SET X=$GET(ORVAL("SPECSTS"))
SET SPCACT=$SELECT('X:"O",$LENGTH($PIECE(X,U,3)):"A",1:"L")
+6 SET SPCUID=$SELECT(SPCACT="A":$PIECE(X,U,3),1:"")
+7 SET Y="OBR|1|"_ORIFN_"^OR|"_$GET(FILLER)_"|"_OI_"^^"_MOD_"|||||||"_SPCACT_"||"_$GET(ORLAB)_"||"_SPCUID_"^^"_TYPE_"||||||||||||"_$$QT
+8 QUIT Y
+9 ;
USID(IFN) ; -- Return USID for order IFN
+1 NEW OI,OI0,OID,OIX,Y
SET Y=""
+2 SET OI=+$ORDER(^OR(100,+$GET(IFN),.1,"B",0))
IF OI
Begin DoDot:1
+3 SET OI0=$GET(^ORD(101.43,OI,0))
SET OID=$PIECE(OI0,U,2)
+4 SET OIX=$PIECE(OI0,U,8)
IF OIX["&"
SET OIX=$PIECE(OIX,"&")_"\T\"_$PIECE(OIX,"&",2)
+5 SET Y=+OID_U_OIX_U_$PIECE(OID,";",2)
End DoDot:1
+6 QUIT Y
+7 ;
NTE() ; -- NTE segment
+1 NEW Y
SET Y="NTE|1||"_$GET(ORVAL("COMMENT"))
+2 QUIT Y
+3 ;
DG1(DFN) ; -- DG1 segment
+1 NEW VAIP,VAERR,Y
+2 SET DFN=+$GET(DFN)
DO IN5^VADPT
+3 SET Y="DG1|1||^^^^"_$GET(VAIP(9))_"^|||A"
+4 QUIT Y
+5 ;
QT() ; -- Build and return Quantity/Timing field
+1 NEW X,Y,%DT,X1,X4,X5,X6,X8,ORI
+2 SET X=$GET(ORVAL("QTY"))
SET X1=$SELECT(X:+X_$SELECT(X["ML":"&ML",1:""),1:"")
+3 SET (X4,X5)=""
FOR ORI="START^4","DATETIME^5"
Begin DoDot:1
+4 SET X=$GET(ORVAL($PIECE(ORI,U)))
SET %DT="TX"
DO ^%DT
if Y<1
QUIT
+5 SET X=$$HL7DATE(Y)
SET @("X"_$PIECE(ORI,U,2))=X
End DoDot:1
+6 SET X=$GET(ORVAL("URGENCY"))
SET X6=$PIECE($GET(^ORD(101.42,+X,0)),U,2)
+7 ;S X=$G(ORVAL("XFUSION")),X7=$S(X="H":"HOLD",X="I":"IMMEDIATE",1:"")
+8 SET X8=$GET(ORVAL("MISC"))
+9 SET Y=X1_U_U_U_X4_U_X5_U_X6_U_U_X8
+10 QUIT Y
+11 ;
DIV() ; -- Return Institution file #4 ptr for LOC
+1 NEW X,Y
SET X=+$GET(DUZ(2))
+2 SET Y=$PIECE($GET(^DIC(4,X,99)),U)_U_$PIECE($GET(^DIC(4,X,0)),U)
+3 QUIT Y
+4 ;
ZDIV(LOC) ; -- Return Institution file #4 ptr for LOC
+1 NEW X0,Y
SET X0=$GET(^SC(+LOC,0))
+2 IF $PIECE(X0,U,15)
SET X=$$SITE^VASITE(DT,$PIECE(X0,U,15))
SET Y=$PIECE(X,U,3)_U_$PIECE(X,U,2)
+3 ;look up #40.8 ptr??
IF '$PIECE(X0,U,15)
SET X=$SELECT($PIECE(X0,U,4):$PIECE(X0,U,4),1:+$GET(DUZ(2)))
SET Y=X_U_$PIECE($GET(^DIC(4,+X,0)),U)
+4 QUIT Y
+5 ;
TYPE(X) ; -- Expands collection type code into text
+1 if '$LENGTH($GET(X))
QUIT ""
+2 IF X="SP"
QUIT "SEND PATIENT"
+3 SET X=$EXTRACT(X)
SET X=$SELECT(X="L":"LAB",X="I":"IMMEDIATE",1:"WARD")
+4 QUIT X_" COLLECT"
