- ORM ; SLC/MKB/JDL - ORM msg router ;15-Jun-2010 21:22;PLS
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,97,141,187,1005,195,1010**;Dec 17, 1997;Build 47
- ; Modified - IHS/MSC/DKM - 01/16/08 - SAVEVAL EP
- EN(MSG) ; -- main entry point for OR RECEIVE where MSG contains HL7 msg
- N ORMSG,ORNMSP,ORTYPE,MSH,PID,PV1,ORC,ORVP,ORTS,ORL,ORCAT,ORAPPT
- S ORAPPT="",ORL=0
- S ORMSG=$S($L($G(MSG)):MSG,1:"MSG") ; MSG="NAME" or MSG(#)=message
- I '$O(@ORMSG@(0)) D EN^ORERR("Missing HL7 message",.ORMSG) Q
- S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH"
- I 'MSH D EN^ORERR("Missing or invalid MSH segment",.ORMSG) Q
- S ORNMSP=$$NMSP($P(@ORMSG@(MSH),"|",3)),ORTYPE=$P(@ORMSG@(MSH),"|",9)
- I '$L(ORNMSP) D EN^ORERR("Missing or invalid sending application",.ORMSG) Q
- D PID I '$G(ORVP) D EN^ORERR("Missing or invalid patient ID",.ORMSG) Q
- D PV1 S ORC=PID
- EN1 F S ORC=$O(@ORMSG@(+ORC)) Q:ORC'>0 I $E(@ORMSG@(ORC),1,3)="ORC" D
- . N ORDCNTRL,ORDSTS,PKGIFN,ORIFN,ORNP,ORTN,ORERR,ORLOG,ORDUZ,ORQT,ORSTRT,ORSTOP,ORURG,ORNATR,OREASON
- . S ORC=ORC_U_@ORMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
- . I '$L(ORDCNTRL) S ORERR="Invalid control code" D ERROR Q
- . S ORIFN=$P($P(ORC,"|",3),U),PKGIFN=$P($P(ORC,"|",4),U)
- . I ORIFN,$D(^OR(100,+ORIFN,0)),$P(^(0),U,2)'=ORVP S ORERR="Patient doesn't match" D ERROR Q
- . S ORDSTS=$P(ORC,"|",6),ORQT=$P(ORC,"|",8)
- . S ORSTRT=$$FMDATE($P(ORQT,U,4)),ORSTOP=$$FMDATE($P(ORQT,U,5))
- . S ORURG=$$URGENCY($P(ORQT,U,6)),ORLOG=$$FMDATE($P(ORC,"|",10))
- . S ORDUZ=+$P(ORC,"|",11),ORNP=+$P(ORC,"|",13),OREASON=$P(ORC,"|",17)
- . S ORNATR=$S($P(OREASON,U,3)="99ORN":$P(OREASON,U),1:"")
- . S ORTN="EN^ORM"_ORNMSP D @ORTN I $D(ORERR) D ERROR Q
- . I ORDCNTRL="SN",$G(ORIFN) D MSG^ORMBLD(ORIFN,"NA")
- . I $G(DGPMT),ORDCNTRL="OD"!(ORDCNTRL="OC") D XTMP
- Q
- ;
- NMSP(NAME) ; -- Returns pkg namespace
- I NAME="RADIOLOGY"!(NAME="IMAGING") Q "RA"
- I NAME="LABORATORY" Q "LR"
- I NAME="DIETETICS" Q "FH"
- I NAME="PHARMACY" Q "PS"
- I NAME="CONSULTS" Q "GMRC"
- I NAME="PROCEDURES" Q "GMRC"
- I NAME="ORDER ENTRY" Q "ORG"
- Q ""
- ;
- PID ; -- Returns patient from PID segment in current msg
- ; Sets PID, ORVP, ORTS if valid patient
- N I,DFN,SEG S I=MSH,PID=""
- F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="PID" D Q
- . S DFN=+$P(@ORMSG@(I),"|",4),PID=I
- . I $D(^DPT(DFN,0)) S ORVP=DFN_";DPT(",ORTS=$G(^DPT(DFN,.103)) Q
- . S:$L($P(@ORMSG@(I),"|",5)) ORVP=$P(@ORMSG@(I),"|",5) ; alt ID for Lab
- Q
- ;
- PV1 ; -- Returns patient location in PV1 segment in current msg
- ; Sets PV1, ORCAT, & ORL if valid location, ORAPPT: IMO appointment
- N I,X,SEG S I=PID,PV1=""
- F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="PV1" D Q
- . S X=+$P(@ORMSG@(I),"|",4),ORCAT=$P(@ORMSG@(I),"|",3),PV1=I
- . S:$D(^SC(X,0)) ORL=X_";SC("
- . S ORAPPT=$P(@ORMSG@(I),"|",45)
- . S:+$G(ORAPPT) ORAPPT=$$FMDATE($G(ORAPPT))
- Q
- ;
- ORDITEM(USID) ; -- Returns pointer to Orderable Item file for USID
- N ID,OI
- S ID=$P(USID,U,4)_";"_$P(USID,U,6)
- S OI=+$O(^ORD(101.43,"ID",ID,0))
- Q OI
- ;
- URGENCY(CODE) ; -- Return ptr to Order Urgency file #101.42
- S:'$L(CODE) CODE="R"
- Q $O(^ORD(101.42,"C",CODE,0))
- ;
- FMDATE(Y) ; -- Convert HL7 date/time to FM format
- Q $$HL7TFM^XLFDT(Y) ;**97
- ;
- ERROR ; -- Sends a DE reply to current msg
- ; Uses ORVP, ORNMSP, ORDUZ, ORIFN, ORERR, and PKGIFN
- N ORV S ORV("XQY0")="" D EN^ORERR(ORERR,.ORMSG,.ORV)
- Q:ORTYPE="ORR" Q:'$L($G(ORNMSP))
- N OREMSG,ORVP,ORTS S:'$G(ORDUZ) ORDUZ=DUZ D:'$G(ORVP) PID
- S OREMSG(1)=$$MSH^ORMBLD("ORR",ORNMSP),OREMSG(2)=$$PID^ORMBLD($G(ORVP))
- S OREMSG(3)="ORC|DE|"_$S($G(ORIFN):ORIFN_"^OR",1:"")_"|"_$S($L($G(PKGIFN)):PKGIFN_U_ORNMSP,1:"")_"|||||||"_ORDUZ_"||||||"_ORERR
- D MSG^XQOR("OR EVSEND "_ORNMSP,.OREMSG)
- Q
- ;
- FIND(SEG,PIECE) ; -- Returns value in $P(@ORMSG@(SEG),"|",PIECE)
- N X,Y,FLDS,I,DONE
- S X=$G(@ORMSG@(SEG)),FLDS=$L(X,"|"),Y="",(I,DONE)=0
- F D Q:DONE
- . I PIECE<FLDS S Y=$P(X,"|",PIECE),DONE=1 Q
- . I PIECE=FLDS D Q
- . . S Y=$P(X,"|",PIECE),I=$O(@ORMSG@(SEG,I)),DONE=1
- . . I I S Y=Y_$P($G(@ORMSG@(SEG,I)),"|")
- . S I=$O(@ORMSG@(SEG,I)) I 'I S Y="",DONE=1 Q
- . S PIECE=PIECE-(FLDS-1),X=$G(@ORMSG@(SEG,I)),FLDS=$L(X,"|")
- FQ Q Y
- ;
- XTMP ; -- Save package auto-dc'd order numbers in ^XTMP
- ; Uses ORIFN, ORNMSP
- Q:'$G(ORIFN) Q:"^1^13^"'[($P($G(^OR(100,+ORIFN,3)),U,3)_U)
- N ORNOW,ORDC S ORNOW=+$$NOW^XLFDT,ORDC="ORDC-"_$G(DGPMDA)
- I $G(^XTMP(ORDC,0)),+^(0)<ORNOW K ^XTMP(ORDC)
- I '$G(^XTMP(ORDC,0)) D
- . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
- . S ^XTMP(ORDC,0)=ORNOW1H_U_ORNOW_"^Orders AutoDC'd by Packages on Discharge"
- S ^XTMP(ORDC,+ORIFN)=$G(ORNMSP)
- Q
- ; IHS/MSC/DKM - Save prompt value in ORDIALOG
- SAVEVAL(ORIFN,PMPT) ;EP
- N PTR,INST,VAL
- S PTR=$O(^ORD(101.41,"AB",$E("OR GTX "_PMPT,1,63),0))
- I PTR F INST=1:1 S VAL=$$VALUE^ORCSAVE2(+ORIFN,PMPT,INST) Q:'$L(VAL) S ORDIALOG(PTR,INST)=VAL
- Q
- ORM ; SLC/MKB/JDL - ORM msg router ;15-Jun-2010 21:22;PLS
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,97,141,187,1005,195,1010**;Dec 17, 1997;Build 47
- +2 ; Modified - IHS/MSC/DKM - 01/16/08 - SAVEVAL EP
- EN(MSG) ; -- main entry point for OR RECEIVE where MSG contains HL7 msg
- +1 NEW ORMSG,ORNMSP,ORTYPE,MSH,PID,PV1,ORC,ORVP,ORTS,ORL,ORCAT,ORAPPT
- +2 SET ORAPPT=""
- SET ORL=0
- +3 ; MSG="NAME" or MSG(#)=message
- SET ORMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
- +4 IF '$ORDER(@ORMSG@(0))
- DO EN^ORERR("Missing HL7 message",.ORMSG)
- QUIT
- +5 SET MSH=0
- FOR
- SET MSH=$ORDER(@ORMSG@(MSH))
- IF MSH'>0
- QUIT
- IF $EXTRACT(@ORMSG@(MSH),1,3)="MSH"
- QUIT
- +6 IF 'MSH
- DO EN^ORERR("Missing or invalid MSH segment",.ORMSG)
- QUIT
- +7 SET ORNMSP=$$NMSP($PIECE(@ORMSG@(MSH),"|",3))
- SET ORTYPE=$PIECE(@ORMSG@(MSH),"|",9)
- +8 IF '$LENGTH(ORNMSP)
- DO EN^ORERR("Missing or invalid sending application",.ORMSG)
- QUIT
- +9 DO PID
- IF '$GET(ORVP)
- DO EN^ORERR("Missing or invalid patient ID",.ORMSG)
- QUIT
- +10 DO PV1
- SET ORC=PID
- EN1 FOR
- SET ORC=$ORDER(@ORMSG@(+ORC))
- IF ORC'>0
- QUIT
- IF $EXTRACT(@ORMSG@(ORC),1,3)="ORC"
- Begin DoDot:1
- +1 NEW ORDCNTRL,ORDSTS,PKGIFN,ORIFN,ORNP,ORTN,ORERR,ORLOG,ORDUZ,ORQT,ORSTRT,ORSTOP,ORURG,ORNATR,OREASON
- +2 SET ORC=ORC_U_@ORMSG@(ORC)
- SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
- +3 IF '$LENGTH(ORDCNTRL)
- SET ORERR="Invalid control code"
- DO ERROR
- QUIT
- +4 SET ORIFN=$PIECE($PIECE(ORC,"|",3),U)
- SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
- +5 IF ORIFN
- IF $DATA(^OR(100,+ORIFN,0))
- IF $PIECE(^(0),U,2)'=ORVP
- SET ORERR="Patient doesn't match"
- DO ERROR
- QUIT
- +6 SET ORDSTS=$PIECE(ORC,"|",6)
- SET ORQT=$PIECE(ORC,"|",8)
- +7 SET ORSTRT=$$FMDATE($PIECE(ORQT,U,4))
- SET ORSTOP=$$FMDATE($PIECE(ORQT,U,5))
- +8 SET ORURG=$$URGENCY($PIECE(ORQT,U,6))
- SET ORLOG=$$FMDATE($PIECE(ORC,"|",10))
- +9 SET ORDUZ=+$PIECE(ORC,"|",11)
- SET ORNP=+$PIECE(ORC,"|",13)
- SET OREASON=$PIECE(ORC,"|",17)
- +10 SET ORNATR=$SELECT($PIECE(OREASON,U,3)="99ORN":$PIECE(OREASON,U),1:"")
- +11 SET ORTN="EN^ORM"_ORNMSP
- DO @ORTN
- IF $DATA(ORERR)
- DO ERROR
- QUIT
- +12 IF ORDCNTRL="SN"
- IF $GET(ORIFN)
- DO MSG^ORMBLD(ORIFN,"NA")
- +13 IF $GET(DGPMT)
- IF ORDCNTRL="OD"!(ORDCNTRL="OC")
- DO XTMP
- End DoDot:1
- +14 QUIT
- +15 ;
- NMSP(NAME) ; -- Returns pkg namespace
- +1 IF NAME="RADIOLOGY"!(NAME="IMAGING")
- QUIT "RA"
- +2 IF NAME="LABORATORY"
- QUIT "LR"
- +3 IF NAME="DIETETICS"
- QUIT "FH"
- +4 IF NAME="PHARMACY"
- QUIT "PS"
- +5 IF NAME="CONSULTS"
- QUIT "GMRC"
- +6 IF NAME="PROCEDURES"
- QUIT "GMRC"
- +7 IF NAME="ORDER ENTRY"
- QUIT "ORG"
- +8 QUIT ""
- +9 ;
- PID ; -- Returns patient from PID segment in current msg
- +1 ; Sets PID, ORVP, ORTS if valid patient
- +2 NEW I,DFN,SEG
- SET I=MSH
- SET PID=""
- +3 FOR
- SET I=$ORDER(@ORMSG@(I))
- IF I'>0
- QUIT
- SET SEG=$EXTRACT(@ORMSG@(I),1,3)
- IF SEG="ORC"
- QUIT
- IF SEG="PID"
- Begin DoDot:1
- +4 SET DFN=+$PIECE(@ORMSG@(I),"|",4)
- SET PID=I
- +5 IF $DATA(^DPT(DFN,0))
- SET ORVP=DFN_";DPT("
- SET ORTS=$GET(^DPT(DFN,.103))
- QUIT
- +6 ; alt ID for Lab
- IF $LENGTH($PIECE(@ORMSG@(I),"|",5))
- SET ORVP=$PIECE(@ORMSG@(I),"|",5)
- End DoDot:1
- QUIT
- +7 QUIT
- +8 ;
- PV1 ; -- Returns patient location in PV1 segment in current msg
- +1 ; Sets PV1, ORCAT, & ORL if valid location, ORAPPT: IMO appointment
- +2 NEW I,X,SEG
- SET I=PID
- SET PV1=""
- +3 FOR
- SET I=$ORDER(@ORMSG@(I))
- IF I'>0
- QUIT
- SET SEG=$EXTRACT(@ORMSG@(I),1,3)
- IF SEG="ORC"
- QUIT
- IF SEG="PV1"
- Begin DoDot:1
- +4 SET X=+$PIECE(@ORMSG@(I),"|",4)
- SET ORCAT=$PIECE(@ORMSG@(I),"|",3)
- SET PV1=I
- +5 IF $DATA(^SC(X,0))
- SET ORL=X_";SC("
- +6 SET ORAPPT=$PIECE(@ORMSG@(I),"|",45)
- +7 IF +$GET(ORAPPT)
- SET ORAPPT=$$FMDATE($GET(ORAPPT))
- End DoDot:1
- QUIT
- +8 QUIT
- +9 ;
- ORDITEM(USID) ; -- Returns pointer to Orderable Item file for USID
- +1 NEW ID,OI
- +2 SET ID=$PIECE(USID,U,4)_";"_$PIECE(USID,U,6)
- +3 SET OI=+$ORDER(^ORD(101.43,"ID",ID,0))
- +4 QUIT OI
- +5 ;
- URGENCY(CODE) ; -- Return ptr to Order Urgency file #101.42
- +1 IF '$LENGTH(CODE)
- SET CODE="R"
- +2 QUIT $ORDER(^ORD(101.42,"C",CODE,0))
- +3 ;
- FMDATE(Y) ; -- Convert HL7 date/time to FM format
- +1 ;**97
- QUIT $$HL7TFM^XLFDT(Y)
- +2 ;
- ERROR ; -- Sends a DE reply to current msg
- +1 ; Uses ORVP, ORNMSP, ORDUZ, ORIFN, ORERR, and PKGIFN
- +2 NEW ORV
- SET ORV("XQY0")=""
- DO EN^ORERR(ORERR,.ORMSG,.ORV)
- +3 IF ORTYPE="ORR"
- QUIT
- IF '$LENGTH($GET(ORNMSP))
- QUIT
- +4 NEW OREMSG,ORVP,ORTS
- IF '$GET(ORDUZ)
- SET ORDUZ=DUZ
- IF '$GET(ORVP)
- DO PID
- +5 SET OREMSG(1)=$$MSH^ORMBLD("ORR",ORNMSP)
- SET OREMSG(2)=$$PID^ORMBLD($GET(ORVP))
- +6 SET OREMSG(3)="ORC|DE|"_$SELECT($GET(ORIFN):ORIFN_"^OR",1:"")_"|"_$SELECT($LENGTH($GET(PKGIFN)):PKGIFN_U_ORNMSP,1:"")_"|||||||"_ORDUZ_"||||||"_ORERR
- +7 DO MSG^XQOR("OR EVSEND "_ORNMSP,.OREMSG)
- +8 QUIT
- +9 ;
- FIND(SEG,PIECE) ; -- Returns value in $P(@ORMSG@(SEG),"|",PIECE)
- +1 NEW X,Y,FLDS,I,DONE
- +2 SET X=$GET(@ORMSG@(SEG))
- SET FLDS=$LENGTH(X,"|")
- SET Y=""
- SET (I,DONE)=0
- +3 FOR
- Begin DoDot:1
- +4 IF PIECE<FLDS
- SET Y=$PIECE(X,"|",PIECE)
- SET DONE=1
- QUIT
- +5 IF PIECE=FLDS
- Begin DoDot:2
- +6 SET Y=$PIECE(X,"|",PIECE)
- SET I=$ORDER(@ORMSG@(SEG,I))
- SET DONE=1
- +7 IF I
- SET Y=Y_$PIECE($GET(@ORMSG@(SEG,I)),"|")
- End DoDot:2
- QUIT
- +8 SET I=$ORDER(@ORMSG@(SEG,I))
- IF 'I
- SET Y=""
- SET DONE=1
- QUIT
- +9 SET PIECE=PIECE-(FLDS-1)
- SET X=$GET(@ORMSG@(SEG,I))
- SET FLDS=$LENGTH(X,"|")
- End DoDot:1
- IF DONE
- QUIT
- FQ QUIT Y
- +1 ;
- XTMP ; -- Save package auto-dc'd order numbers in ^XTMP
- +1 ; Uses ORIFN, ORNMSP
- +2 IF '$GET(ORIFN)
- QUIT
- IF "^1^13^"'[($PIECE($GET(^OR(100,+ORIFN,3)),U,3)_U)
- QUIT
- +3 NEW ORNOW,ORDC
- SET ORNOW=+$$NOW^XLFDT
- SET ORDC="ORDC-"_$GET(DGPMDA)
- +4 IF $GET(^XTMP(ORDC,0))
- IF +^(0)<ORNOW
- KILL ^XTMP(ORDC)
- +5 IF '$GET(^XTMP(ORDC,0))
- Begin DoDot:1
- +6 NEW ORNOW1H
- SET ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
- +7 SET ^XTMP(ORDC,0)=ORNOW1H_U_ORNOW_"^Orders AutoDC'd by Packages on Discharge"
- End DoDot:1
- +8 SET ^XTMP(ORDC,+ORIFN)=$GET(ORNMSP)
- +9 QUIT
- +10 ; IHS/MSC/DKM - Save prompt value in ORDIALOG
- SAVEVAL(ORIFN,PMPT) ;EP
- +1 NEW PTR,INST,VAL
- +2 SET PTR=$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_PMPT,1,63),0))
- +3 IF PTR
- FOR INST=1:1
- SET VAL=$$VALUE^ORCSAVE2(+ORIFN,PMPT,INST)
- IF '$LENGTH(VAL)
- QUIT
- SET ORDIALOG(PTR,INST)=VAL
- +4 QUIT
