- 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 Mar 13, 2025@21:36:48 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"
