- ORMBLD ; SLC/MKB/JDL - Build outgoing ORM msgs ;05/10/17 10:08
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,33,26,45,79,97,133,168,187,190,195,215,350,434**;Dec 17, 1997;Build 35
- ;
- ;
- ;
- NEW(IFN,CODE) ; -- Send NW order message to pkg
- ;I $P($G(^ORD(101.42,+$$VALUE^ORCSAVE2(IFN,"URGENCY"),0)),U)="DONE" D STATUS^ORCSAVE2(IFN,2) Q ; complete -> don't send to pkg
- N ORPKG,ORMSG,DGQUIET K ^TMP("ORWORD",$J)
- S DGQUIET=1 D Q:'$O(ORMSG(0)) ;build msg, ORDIALOG gone when posted
- . N OR0,OR3,OR8,ORVP,ORDG,ORDIALOG,ORPARENT S:'$D(CODE) CODE="NW"
- . S OR0=$G(^OR(100,IFN,0)) Q:'$L(OR0) S OR3=$G(^(3)),OR8=$G(^(8,1,0))
- . S ORVP=$P(OR0,U,2),ORDG=$P(OR0,U,11),ORPKG=$$NMSP^ORCD($P(OR0,U,14))
- . Q:"^GMRA^GMRC^FH^LR^PS^RA^OR^SD^"'[(U_ORPKG_U)
- . S ORDIALOG=+$P(OR0,U,5) Q:'ORDIALOG
- . D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(IFN)
- . S ORMSG(1)=$$MSH("ORM",ORPKG),ORMSG(2)=$$PID(ORVP)
- . S ORMSG(3)=$$PV1(ORVP,$P(OR0,U,12),+$P(OR0,U,10),"",$P(OR0,U,18))
- . S ORPARENT=$P(OR3,U,9) I ORPARENT,$G(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),1))="NOW"!'$O(^OR(100,+ORPARENT,4.5,"ID","CONJ",0)) S ORPARENT="" ;no parent if NOW or only child
- . S ORMSG(4)="ORC|"_CODE_"|"_+OR0_";1^OR||||||"_ORPARENT_"|"_$$HL7DATE($P(OR0,U,7))_"|"_+$P(OR0,U,6)_"||"_+$P(OR0,U,4)_"|||"_$$HL7DATE($$NOW^XLFDT)_"|"_$$NATURE($P(OR8,U,12))_"^^^"
- . D @ORPKG K ^TMP("ORWORD",$J)
- I $G(ORZTEST) M ORZTEST=ORMSG Q ;testing only
- D MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
- Q
- ;
- MSG(IFN,CODE,REASON) ; -- Send all other order msgs
- N ORPKG,ORMSG,DGQUIET K ^TMP("ORWORD",$J)
- S DGQUIET=1 D Q:'$O(ORMSG(0)) ; build message
- . N OR0,OR8,DG,PKGID,I,TYPE,DA,PROV,NATR,STS,OI
- . S OR0=$G(^OR(100,+IFN,0)),PKGID=$G(^(4)),STS=$P($G(^(3)),U,3)
- . S ORPKG=$$NMSP^ORCD($P(OR0,U,14))
- . I ORPKG="VBEC" D:$L($T(CA^ORMBLDVB)) CA^ORMBLDVB(IFN,$G(REASON)) Q
- . Q:"^GMRA^GMRC^FH^LR^PS^RA^OR^SD^"'[(U_ORPKG_U)
- . I ORPKG="LR" S ORPKG="LRCH" S:CODE="DC" CODE="CA" ;DC if VBEC child
- . S DA=+$P(IFN,";",2),OR8=$G(^OR(100,+IFN,8,DA,0))
- . S PROV=$P(OR8,U,3),NATR=$P(OR8,U,12) S:'PROV PROV=$G(ORNP)
- . S TYPE=$S(CODE="NA"!(CODE="DE"):"ORR",1:"ORM")
- . S ORMSG(1)=$$MSH(TYPE,ORPKG),ORMSG(2)=$$PID($P(OR0,U,2)),I=2
- . I ORPKG="SD",CODE="DC" D DC^ORMBLDSD Q
- . I ORPKG="PS"!(ORPKG="FH"&($P(OR0,U,12)="O")) S I=I+1,ORMSG(I)=$$PV1($P(OR0,U,2),$P(OR0,U,12),+$P(OR0,U,10))
- . S I=I+1,ORMSG(I)="ORC|"_CODE_"|"_IFN_"^OR|"_PKGID_U_ORPKG_"||||||"_$S($G(DGPMA):$$HL7DATE($P(DGPMA,U)),1:"")_"|"_DUZ_"||"_PROV_"|||"_$$HL7DATE($$NOW^XLFDT)_"|"_$$REASON(+$G(REASON),NATR)
- . I ORPKG="FH",CODE="SS" S $P(ORMSG(I),"|",6)=$S(STS=8:"SC",STS=6:"IP",1:"")
- . I $E(ORPKG,1,2)="LR" S OI=+$O(^OR(100,+IFN,.1,0)),OI=+$G(^(OI,0)) S:OI I=I+1,ORMSG(I)="OBR||||"_$$USID(OI)
- . I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D
- . . I (CODE="CA")!(CODE="DC") S I=I+1,ORMSG(I)="ZRN|N"
- . K ^TMP("ORWORD",$J)
- D MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
- Q
- ;
- BHS(PAT) ; -- Send batch header segment/message to Lab
- N ORMSG S ORMSG(1)="BHS|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|LABORATORY|"_$G(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)
- S ORMSG(2)=$$PID($G(PAT))
- D MSG^XQOR("OR EVSEND LRCH",.ORMSG)
- Q
- ;
- BTS(PAT) ; -- Send batch trailer segment/message to Lab
- N ORMSG S ORMSG(1)="BTS",ORMSG(2)=$$PID($G(PAT))
- D MSG^XQOR("OR EVSEND LRCH",.ORMSG)
- Q
- ;
- MSH(TYPE,TO) ; -- MSH segment
- N MSH
- S MSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|"_$$NAME(TO)_"|"_$G(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)_"||"_TYPE
- Q MSH
- ;
- NAME(NMSP) ; -- Returns name of pkg NMSP
- I NMSP="GMRA" Q "ALLERGIES"
- I NMSP="GMRC" Q "CONSULTS"
- I NMSP="FH" Q "DIETETICS"
- I NMSP?1"LR".E Q "LABORATORY"
- I NMSP="PS" Q "PHARMACY"
- I NMSP="RA" Q "RADIOLOGY"
- I NMSP="OR" Q "ORDER ENTRY"
- I NMSP="SD" Q "SCHEDULING"
- Q ""
- ;
- PID(DFN) ; -- PID segment
- N PID,PTR,ROOT
- S PTR=+$P(DFN,";"),ROOT=$P(DFN,";",2),PID="PID|||"
- I ROOT="DPT(" S PID=PID_PTR_"||"_$P($G(^DPT(PTR,0)),U)
- E S PID=PID_"|"_DFN_"|"_$S($L(ROOT):$P($G(@(U_ROOT_PTR_",0)")),U),1:"")
- Q PID
- ;
- PV1(OBJ,TYPE,LOC,VISIT,APPTDT) ; -- PV1 segment
- N PV1,RB,PACH S RB=""
- S:$G(APPTDT) APPTDT=$$FMTHL7^XLFDT(APPTDT)
- I TYPE="I",+OBJ,$P(OBJ,";",2)="DPT(" S RB=$P($G(^DPT(+OBJ,.101)),U)
- S PACH=$$PATCH^XPDUTL("PSJ*5.0*111")
- S:PACH PV1="PV1||"_TYPE_"|"_LOC_$S($L(RB):U_RB,1:"")_"||||||||||||||||"_$G(VISIT)_"|||||||||||||||||||||||||"_$G(APPTDT)
- S:'PACH PV1="PV1||"_TYPE_"|"_LOC_$S($L(RB):U_RB,1:"")_"||||||||||||||||"_$G(VISIT)
- Q PV1
- ;
- HL7DATE(DATE) ; -- FM -> HL7 format
- Q $$FMTHL7^XLFDT(DATE) ;**97
- ;
- USID(OI) ; -- Returns Univ Serv ID for Orderable Item
- N OITEM,NATL,LOCAL S OITEM=$G(^ORD(101.43,+OI,0))
- S NATL=$P(OITEM,U,3)_U_U_$P(OITEM,U,4)
- S LOCAL=$P($P(OITEM,U,2),";")_U_$P(OITEM,U)_U_$P($P(OITEM,U,2),";",2)
- Q NATL_U_LOCAL
- ;
- NATURE(X) ; -- Returns 3 ^-piece identifier for nature X
- N ORN,Y S ORN=$G(^ORD(100.02,+$G(X),0))
- S Y=$P(ORN,U,2)_U_$P(ORN,U)_"^99ORN"
- Q Y
- ;
- REASON(X,N) ; -- Returns 6 ^-piece format of reason X
- ; N ^ NATURE ^ 99ORN ^ # ^ Reason ^ 99ORR
- N Y,ORR S ORR=$G(^ORD(100.03,+$G(X),0))
- S:'$G(N) N=+$P(ORR,U,7) S Y=$$NATURE(N)
- S:$G(X) Y=Y_U_$S(ORPKG'="RA":+X,1:"")_U_$P(ORR,U)_"^99ORR"
- Q Y
- ;
- IP() ; -- Returns ORIFN^Type if pt has active isolation order (or 0 if not)
- N TYPE,START,ORIFN,Y
- S TYPE=$O(^ORD(100.98,"B","PREC",0)),START=$$NOW^XLFDT,Y=0
- F S START=$O(^OR(100,"AW",ORVP,TYPE,START),-1) Q:START'>0 S ORIFN=$O(^(START,0)) I $P($G(^OR(100,ORIFN,3)),U,3)=6 S Y=ORIFN Q
- I Y S TYPE=$$VALUE^ORCSAVE2(ORIFN,"ISOLATION"),Y=Y_U_$$GET1^DIQ(119.4,+TYPE_",",.01)
- Q Y
- ;
- OR ; -- new Generic order
- I ORDG=$O(^ORD(100.98,"B","M.A.S.",0)) D ADT^ORMBLDOR Q
- D EN^ORMBLDOR
- Q
- ;
- GMRA ; -- new Allergy order
- Q:$$PATCH^XPDUTL("OR*3.0*216") ;195 quit if patch 216 is in
- D:$L($T(ALG^ORMBLDAL)) ALG^ORMBLDAL
- Q
- ;
- GMRC ; -- new Consult order
- D CSLT^ORMBLDGM
- Q
- ;
- FH ; -- new Diet order
- N ORPARAM D EN^FHWOR8(+ORVP,.ORPARAM) ; set parameters
- S:'$L($G(ORPARAM(3))) ORPARAM(3)="T"
- I ORDG=$O(^ORD(100.98,"B","PRECAUTIONS",0)) D IP^ORMBLDFH Q
- I ORDG=$O(^ORD(100.98,"B","EARLY/LATE TRAYS",0)) D TRAY^ORMBLDFH Q
- I ORDG=$O(^ORD(100.98,"B","TUBEFEEDINGS",0)) D TF^ORMBLDFH Q
- I ORDG=$O(^ORD(100.98,"B","DIET ADDITIONAL ORDERS",0)) D ADDN^ORMBLDFH Q
- D DIET^ORMBLDFH
- Q
- ;
- LR ; -- new Lab order
- I CODE="XO" D XO^ORMBLDLR Q ; change
- D CH^ORMBLDLR S ORPKG="LRCH" Q ;no difference by subscript at this time
- N SUB S SUB=$P($G(^ORD(100.98,ORDG,0)),U,3)
- S:(SUB="SP")!(SUB="EM")!(SUB="AU")!(SUB="CY") SUB="AP"
- S:(SUB="LAB")!(SUB="MI")!(SUB="HEMA") SUB="CH"
- D @(SUB_"^ORMBLDLR") S ORPKG=ORPKG_SUB
- Q
- ;
- PS ; -- new Pharmacy order
- ;I ORDG=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) D OUT^ORMBLDPS Q
- ;D UD^ORMBLDPS
- N IVDLG S IVDLG=+$P(OR0,U,5) ;JD
- N PKG S PKG=$P(OR0,U,14),PKG=$$GET1^DIQ(9.4,+PKG_",",1)
- I +$$VALUE^ORCSAVE2(IFN,"URGENCY")=99,$P(OR3,U,11)'="B" D Q ;only send DONE orders from BCMA
- . D STATUS^ORCSAVE2(IFN,2) K ORMSG
- . I $P(OR3,U,11)=1,$P($G(^OR(100,+$P(OR3,U,5),3)),U,3)=5 D MSG(+$P(OR3,U,5),"CA") ;cancel original instead
- I ORDG=$O(^ORD(100.98,"B","IV RX",0))!(ORDG=$O(^ORD(100.98,"B","TPN",0)))!(IVDLG=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)))!(IVDLG=$O(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",0))) D IV^ORMBLDPS Q
- D @($S(PKG="PSIV":"IV",PKG="PSO":"OUT",PKG="PSH":"NVA",1:"UD")_"^ORMBLDPS")
- Q
- ;
- RA ; -- new Radiology order
- D EN^ORMBLDRA
- Q
- ;
- SD ;
- D EN^ORMBLDSD(CODE)
- Q
- ;
- TEST(ORIFN) ; -- Build/display HL7 msgs w/o sending
- K ORZTEST S ORZTEST=1 D NEW(ORIFN) ; leaves msg in ORZTEST() on exit
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMBLD 7562 printed Jan 18, 2025@03:32:53 Page 2
- ORMBLD ; SLC/MKB/JDL - Build outgoing ORM msgs ;05/10/17 10:08
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,33,26,45,79,97,133,168,187,190,195,215,350,434**;Dec 17, 1997;Build 35
- +2 ;
- +3 ;
- +4 ;
- NEW(IFN,CODE) ; -- Send NW order message to pkg
- +1 ;I $P($G(^ORD(101.42,+$$VALUE^ORCSAVE2(IFN,"URGENCY"),0)),U)="DONE" D STATUS^ORCSAVE2(IFN,2) Q ; complete -> don't send to pkg
- +2 NEW ORPKG,ORMSG,DGQUIET
- KILL ^TMP("ORWORD",$JOB)
- +3 ;build msg, ORDIALOG gone when posted
- SET DGQUIET=1
- Begin DoDot:1
- +4 NEW OR0,OR3,OR8,ORVP,ORDG,ORDIALOG,ORPARENT
- if '$DATA(CODE)
- SET CODE="NW"
- +5 SET OR0=$GET(^OR(100,IFN,0))
- if '$LENGTH(OR0)
- QUIT
- SET OR3=$GET(^(3))
- SET OR8=$GET(^(8,1,0))
- +6 SET ORVP=$PIECE(OR0,U,2)
- SET ORDG=$PIECE(OR0,U,11)
- SET ORPKG=$$NMSP^ORCD($PIECE(OR0,U,14))
- +7 if "^GMRA^GMRC^FH^LR^PS^RA^OR^SD^"'[(U_ORPKG_U)
- QUIT
- +8 SET ORDIALOG=+$PIECE(OR0,U,5)
- if 'ORDIALOG
- QUIT
- +9 DO GETDLG1^ORCD(ORDIALOG)
- DO GETORDER^ORCD(IFN)
- +10 SET ORMSG(1)=$$MSH("ORM",ORPKG)
- SET ORMSG(2)=$$PID(ORVP)
- +11 SET ORMSG(3)=$$PV1(ORVP,$PIECE(OR0,U,12),+$PIECE(OR0,U,10),"",$PIECE(OR0,U,18))
- +12 ;no parent if NOW or only child
- SET ORPARENT=$PIECE(OR3,U,9)
- IF ORPARENT
- IF $GET(ORDIALOG($$PTR^ORCD("OR GTX SCHEDULE"),1))="NOW"!'$ORDER(^OR(100,+ORPARENT,4.5,"ID","CONJ",0))
- SET ORPARENT=""
- +13 SET ORMSG(4)="ORC|"_CODE_"|"_+OR0_";1^OR||||||"_ORPARENT_"|"_$$HL7DATE($PIECE(OR0,U,7))_"|"_+$PIECE(OR0,U,6)_"||"_+$PIECE(OR0,U,4)_"|||"_$$HL7DATE($$NOW^XLFDT)_"|"_$$NATURE($PIECE(OR8,U,12))_"^^^"
- +14 DO @ORPKG
- KILL ^TMP("ORWORD",$JOB)
- End DoDot:1
- if '$ORDER(ORMSG(0))
- QUIT
- +15 ;testing only
- IF $GET(ORZTEST)
- MERGE ORZTEST=ORMSG
- QUIT
- +16 DO MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
- +17 QUIT
- +18 ;
- MSG(IFN,CODE,REASON) ; -- Send all other order msgs
- +1 NEW ORPKG,ORMSG,DGQUIET
- KILL ^TMP("ORWORD",$JOB)
- +2 ; build message
- SET DGQUIET=1
- Begin DoDot:1
- +3 NEW OR0,OR8,DG,PKGID,I,TYPE,DA,PROV,NATR,STS,OI
- +4 SET OR0=$GET(^OR(100,+IFN,0))
- SET PKGID=$GET(^(4))
- SET STS=$PIECE($GET(^(3)),U,3)
- +5 SET ORPKG=$$NMSP^ORCD($PIECE(OR0,U,14))
- +6 IF ORPKG="VBEC"
- if $LENGTH($TEXT(CA^ORMBLDVB))
- DO CA^ORMBLDVB(IFN,$GET(REASON))
- QUIT
- +7 if "^GMRA^GMRC^FH^LR^PS^RA^OR^SD^"'[(U_ORPKG_U)
- QUIT
- +8 ;DC if VBEC child
- IF ORPKG="LR"
- SET ORPKG="LRCH"
- if CODE="DC"
- SET CODE="CA"
- +9 SET DA=+$PIECE(IFN,";",2)
- SET OR8=$GET(^OR(100,+IFN,8,DA,0))
- +10 SET PROV=$PIECE(OR8,U,3)
- SET NATR=$PIECE(OR8,U,12)
- if 'PROV
- SET PROV=$GET(ORNP)
- +11 SET TYPE=$SELECT(CODE="NA"!(CODE="DE"):"ORR",1:"ORM")
- +12 SET ORMSG(1)=$$MSH(TYPE,ORPKG)
- SET ORMSG(2)=$$PID($PIECE(OR0,U,2))
- SET I=2
- +13 IF ORPKG="SD"
- IF CODE="DC"
- DO DC^ORMBLDSD
- QUIT
- +14 IF ORPKG="PS"!(ORPKG="FH"&($PIECE(OR0,U,12)="O"))
- SET I=I+1
- SET ORMSG(I)=$$PV1($PIECE(OR0,U,2),$PIECE(OR0,U,12),+$PIECE(OR0,U,10))
- +15 SET I=I+1
- SET ORMSG(I)="ORC|"_CODE_"|"_IFN_"^OR|"_PKGID_U_ORPKG_"||||||"_$SELECT($GET(DGPMA):$$HL7DATE($PIECE(DGPMA,U)),1:"")_"|"_DUZ_"||"_PROV_"|||"_$$HL7DATE($$NOW^XLFDT)_"|"_$$REASON(+$GET(REASON),NATR)
- +16 IF ORPKG="FH"
- IF CODE="SS"
- SET $PIECE(ORMSG(I),"|",6)=$SELECT(STS=8:"SC",STS=6:"IP",1:"")
- +17 IF $EXTRACT(ORPKG,1,2)="LR"
- SET OI=+$ORDER(^OR(100,+IFN,.1,0))
- SET OI=+$GET(^(OI,0))
- if OI
- SET I=I+1
- SET ORMSG(I)="OBR||||"_$$USID(OI)
- +18 IF $PIECE(^ORD(100.98,$PIECE(OR0,U,11),0),U)="NON-VA MEDICATIONS"
- Begin DoDot:2
- +19 IF (CODE="CA")!(CODE="DC")
- SET I=I+1
- SET ORMSG(I)="ZRN|N"
- End DoDot:2
- +20 KILL ^TMP("ORWORD",$JOB)
- End DoDot:1
- if '$ORDER(ORMSG(0))
- QUIT
- +21 DO MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
- +22 QUIT
- +23 ;
- BHS(PAT) ; -- Send batch header segment/message to Lab
- +1 NEW ORMSG
- SET ORMSG(1)="BHS|^~\&|ORDER ENTRY|"_$GET(DUZ(2))_"|LABORATORY|"_$GET(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)
- +2 SET ORMSG(2)=$$PID($GET(PAT))
- +3 DO MSG^XQOR("OR EVSEND LRCH",.ORMSG)
- +4 QUIT
- +5 ;
- BTS(PAT) ; -- Send batch trailer segment/message to Lab
- +1 NEW ORMSG
- SET ORMSG(1)="BTS"
- SET ORMSG(2)=$$PID($GET(PAT))
- +2 DO MSG^XQOR("OR EVSEND LRCH",.ORMSG)
- +3 QUIT
- +4 ;
- MSH(TYPE,TO) ; -- MSH segment
- +1 NEW MSH
- +2 SET MSH="MSH|^~\&|ORDER ENTRY|"_$GET(DUZ(2))_"|"_$$NAME(TO)_"|"_$GET(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)_"||"_TYPE
- +3 QUIT MSH
- +4 ;
- NAME(NMSP) ; -- Returns name of pkg NMSP
- +1 IF NMSP="GMRA"
- QUIT "ALLERGIES"
- +2 IF NMSP="GMRC"
- QUIT "CONSULTS"
- +3 IF NMSP="FH"
- QUIT "DIETETICS"
- +4 IF NMSP?1"LR".E
- QUIT "LABORATORY"
- +5 IF NMSP="PS"
- QUIT "PHARMACY"
- +6 IF NMSP="RA"
- QUIT "RADIOLOGY"
- +7 IF NMSP="OR"
- QUIT "ORDER ENTRY"
- +8 IF NMSP="SD"
- QUIT "SCHEDULING"
- +9 QUIT ""
- +10 ;
- PID(DFN) ; -- PID segment
- +1 NEW PID,PTR,ROOT
- +2 SET PTR=+$PIECE(DFN,";")
- SET ROOT=$PIECE(DFN,";",2)
- SET PID="PID|||"
- +3 IF ROOT="DPT("
- SET PID=PID_PTR_"||"_$PIECE($GET(^DPT(PTR,0)),U)
- +4 IF '$TEST
- SET PID=PID_"|"_DFN_"|"_$SELECT($LENGTH(ROOT):$PIECE($GET(@(U_ROOT_PTR_",0)")),U),1:"")
- +5 QUIT PID
- +6 ;
- PV1(OBJ,TYPE,LOC,VISIT,APPTDT) ; -- PV1 segment
- +1 NEW PV1,RB,PACH
- SET RB=""
- +2 if $GET(APPTDT)
- SET APPTDT=$$FMTHL7^XLFDT(APPTDT)
- +3 IF TYPE="I"
- IF +OBJ
- IF $PIECE(OBJ,";",2)="DPT("
- SET RB=$PIECE($GET(^DPT(+OBJ,.101)),U)
- +4 SET PACH=$$PATCH^XPDUTL("PSJ*5.0*111")
- +5 if PACH
- SET PV1="PV1||"_TYPE_"|"_LOC_$SELECT($LENGTH(RB):U_RB,1:"")_"||||||||||||||||"_$GET(VISIT)_"|||||||||||||||||||||||||"_$GET(APPTDT)
- +6 if 'PACH
- SET PV1="PV1||"_TYPE_"|"_LOC_$SELECT($LENGTH(RB):U_RB,1:"")_"||||||||||||||||"_$GET(VISIT)
- +7 QUIT PV1
- +8 ;
- HL7DATE(DATE) ; -- FM -> HL7 format
- +1 ;**97
- QUIT $$FMTHL7^XLFDT(DATE)
- +2 ;
- USID(OI) ; -- Returns Univ Serv ID for Orderable Item
- +1 NEW OITEM,NATL,LOCAL
- SET OITEM=$GET(^ORD(101.43,+OI,0))
- +2 SET NATL=$PIECE(OITEM,U,3)_U_U_$PIECE(OITEM,U,4)
- +3 SET LOCAL=$PIECE($PIECE(OITEM,U,2),";")_U_$PIECE(OITEM,U)_U_$PIECE($PIECE(OITEM,U,2),";",2)
- +4 QUIT NATL_U_LOCAL
- +5 ;
- NATURE(X) ; -- Returns 3 ^-piece identifier for nature X
- +1 NEW ORN,Y
- SET ORN=$GET(^ORD(100.02,+$GET(X),0))
- +2 SET Y=$PIECE(ORN,U,2)_U_$PIECE(ORN,U)_"^99ORN"
- +3 QUIT Y
- +4 ;
- REASON(X,N) ; -- Returns 6 ^-piece format of reason X
- +1 ; N ^ NATURE ^ 99ORN ^ # ^ Reason ^ 99ORR
- +2 NEW Y,ORR
- SET ORR=$GET(^ORD(100.03,+$GET(X),0))
- +3 if '$GET(N)
- SET N=+$PIECE(ORR,U,7)
- SET Y=$$NATURE(N)
- +4 if $GET(X)
- SET Y=Y_U_$SELECT(ORPKG'="RA":+X,1:"")_U_$PIECE(ORR,U)_"^99ORR"
- +5 QUIT Y
- +6 ;
- IP() ; -- Returns ORIFN^Type if pt has active isolation order (or 0 if not)
- +1 NEW TYPE,START,ORIFN,Y
- +2 SET TYPE=$ORDER(^ORD(100.98,"B","PREC",0))
- SET START=$$NOW^XLFDT
- SET Y=0
- +3 FOR
- SET START=$ORDER(^OR(100,"AW",ORVP,TYPE,START),-1)
- if START'>0
- QUIT
- SET ORIFN=$ORDER(^(START,0))
- IF $PIECE($GET(^OR(100,ORIFN,3)),U,3)=6
- SET Y=ORIFN
- QUIT
- +4 IF Y
- SET TYPE=$$VALUE^ORCSAVE2(ORIFN,"ISOLATION")
- SET Y=Y_U_$$GET1^DIQ(119.4,+TYPE_",",.01)
- +5 QUIT Y
- +6 ;
- OR ; -- new Generic order
- +1 IF ORDG=$ORDER(^ORD(100.98,"B","M.A.S.",0))
- DO ADT^ORMBLDOR
- QUIT
- +2 DO EN^ORMBLDOR
- +3 QUIT
- +4 ;
- GMRA ; -- new Allergy order
- +1 ;195 quit if patch 216 is in
- if $$PATCH^XPDUTL("OR*3.0*216")
- QUIT
- +2 if $LENGTH($TEXT(ALG^ORMBLDAL))
- DO ALG^ORMBLDAL
- +3 QUIT
- +4 ;
- GMRC ; -- new Consult order
- +1 DO CSLT^ORMBLDGM
- +2 QUIT
- +3 ;
- FH ; -- new Diet order
- +1 ; set parameters
- NEW ORPARAM
- DO EN^FHWOR8(+ORVP,.ORPARAM)
- +2 if '$LENGTH($GET(ORPARAM(3)))
- SET ORPARAM(3)="T"
- +3 IF ORDG=$ORDER(^ORD(100.98,"B","PRECAUTIONS",0))
- DO IP^ORMBLDFH
- QUIT
- +4 IF ORDG=$ORDER(^ORD(100.98,"B","EARLY/LATE TRAYS",0))
- DO TRAY^ORMBLDFH
- QUIT
- +5 IF ORDG=$ORDER(^ORD(100.98,"B","TUBEFEEDINGS",0))
- DO TF^ORMBLDFH
- QUIT
- +6 IF ORDG=$ORDER(^ORD(100.98,"B","DIET ADDITIONAL ORDERS",0))
- DO ADDN^ORMBLDFH
- QUIT
- +7 DO DIET^ORMBLDFH
- +8 QUIT
- +9 ;
- LR ; -- new Lab order
- +1 ; change
- IF CODE="XO"
- DO XO^ORMBLDLR
- QUIT
- +2 ;no difference by subscript at this time
- DO CH^ORMBLDLR
- SET ORPKG="LRCH"
- QUIT
- +3 NEW SUB
- SET SUB=$PIECE($GET(^ORD(100.98,ORDG,0)),U,3)
- +4 if (SUB="SP")!(SUB="EM")!(SUB="AU")!(SUB="CY")
- SET SUB="AP"
- +5 if (SUB="LAB")!(SUB="MI")!(SUB="HEMA")
- SET SUB="CH"
- +6 DO @(SUB_"^ORMBLDLR")
- SET ORPKG=ORPKG_SUB
- +7 QUIT
- +8 ;
- PS ; -- new Pharmacy order
- +1 ;I ORDG=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) D OUT^ORMBLDPS Q
- +2 ;D UD^ORMBLDPS
- +3 ;JD
- NEW IVDLG
- SET IVDLG=+$PIECE(OR0,U,5)
- +4 NEW PKG
- SET PKG=$PIECE(OR0,U,14)
- SET PKG=$$GET1^DIQ(9.4,+PKG_",",1)
- +5 ;only send DONE orders from BCMA
- IF +$$VALUE^ORCSAVE2(IFN,"URGENCY")=99
- IF $PIECE(OR3,U,11)'="B"
- Begin DoDot:1
- +6 DO STATUS^ORCSAVE2(IFN,2)
- KILL ORMSG
- +7 ;cancel original instead
- IF $PIECE(OR3,U,11)=1
- IF $PIECE($GET(^OR(100,+$PIECE(OR3,U,5),3)),U,3)=5
- DO MSG(+$PIECE(OR3,U,5),"CA")
- End DoDot:1
- QUIT
- +8 IF ORDG=$ORDER(^ORD(100.98,"B","IV RX",0))!(ORDG=$ORDER(^ORD(100.98,"B","TPN",0)))!(IVDLG=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)))!(IVDLG=$ORDER(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",0)))
- DO IV^ORMBLDPS
- QUIT
- +9 DO @($SELECT(PKG="PSIV":"IV",PKG="PSO":"OUT",PKG="PSH":"NVA",1:"UD")_"^ORMBLDPS")
- +10 QUIT
- +11 ;
- RA ; -- new Radiology order
- +1 DO EN^ORMBLDRA
- +2 QUIT
- +3 ;
- SD ;
- +1 DO EN^ORMBLDSD(CODE)
- +2 QUIT
- +3 ;
- TEST(ORIFN) ; -- Build/display HL7 msgs w/o sending
- +1 ; leaves msg in ORZTEST() on exit
- KILL ORZTEST
- SET ORZTEST=1
- DO NEW(ORIFN)
- +2 QUIT