source: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMBLD.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1ORMBLD ; SLC/MKB/JDL - Build outgoing ORM msgs ;4/12/04 12:33
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,33,26,45,79,97,133,168,187,190,195,215**;Dec 17, 1997
3 ;
4NEW(IFN,CODE) ; -- Send NW order message to pkg
5 ;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
6 N ORPKG,ORMSG,DGQUIET K ^TMP("ORWORD",$J)
7 S DGQUIET=1 D Q:'$O(ORMSG(0)) ;build msg, ORDIALOG gone when posted
8 . N OR0,OR3,OR8,ORVP,ORDG,ORDIALOG,ORPARENT S:'$D(CODE) CODE="NW"
9 . S OR0=$G(^OR(100,IFN,0)) Q:'$L(OR0) S OR3=$G(^(3)),OR8=$G(^(8,1,0))
10 . S ORVP=$P(OR0,U,2),ORDG=$P(OR0,U,11),ORPKG=$$NMSP^ORCD($P(OR0,U,14))
11 . Q:"^GMRA^GMRC^FH^LR^PS^RA^OR^"'[(U_ORPKG_U)
12 . S ORDIALOG=+$P(OR0,U,5) Q:'ORDIALOG
13 . D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(IFN)
14 . S ORMSG(1)=$$MSH("ORM",ORPKG),ORMSG(2)=$$PID(ORVP)
15 . S ORMSG(3)=$$PV1(ORVP,$P(OR0,U,12),+$P(OR0,U,10),"",$P(OR0,U,18))
16 . 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
17 . 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))_"^^^"
18 . D @ORPKG K ^TMP("ORWORD",$J)
19 I $G(ORZTEST) M ORZTEST=ORMSG Q ;testing only
20 D MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
21 Q
22 ;
23MSG(IFN,CODE,REASON) ; -- Send all other order msgs
24 N ORPKG,ORMSG,DGQUIET K ^TMP("ORWORD",$J)
25 S DGQUIET=1 D Q:'$O(ORMSG(0)) ; build message
26 . N OR0,OR8,DG,PKGID,I,TYPE,DA,PROV,NATR,STS,OI
27 . S OR0=$G(^OR(100,+IFN,0)),PKGID=$G(^(4)),STS=$P($G(^(3)),U,3)
28 . S ORPKG=$$NMSP^ORCD($P(OR0,U,14))
29 . I ORPKG="VBEC" D:$L($T(CA^ORMBLDVB)) CA^ORMBLDVB(IFN,$G(REASON)) Q
30 . Q:"^GMRA^GMRC^FH^LR^PS^RA^OR^"'[(U_ORPKG_U)
31 . I ORPKG="LR" S ORPKG="LRCH" S:CODE="DC" CODE="CA" ;DC if VBEC child
32 . S DA=+$P(IFN,";",2),OR8=$G(^OR(100,+IFN,8,DA,0))
33 . S PROV=$P(OR8,U,3),NATR=$P(OR8,U,12) S:'PROV PROV=$G(ORNP)
34 . S TYPE=$S(CODE="NA"!(CODE="DE"):"ORR",1:"ORM")
35 . S ORMSG(1)=$$MSH(TYPE,ORPKG),ORMSG(2)=$$PID($P(OR0,U,2)),I=2
36 . 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))
37 . 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)
38 . I ORPKG="FH",CODE="SS" S $P(ORMSG(I),"|",6)=$S(STS=8:"SC",STS=6:"IP",1:"")
39 . 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)
40 . I $P(^ORD(100.98,$P(OR0,U,11),0),U)="NON-VA MEDICATIONS" D
41 . . I (CODE="CA")!(CODE="DC") S I=I+1,ORMSG(I)="ZRN|N"
42 . K ^TMP("ORWORD",$J)
43 D MSG^XQOR("OR EVSEND "_ORPKG,.ORMSG)
44 Q
45 ;
46BHS(PAT) ; -- Send batch header segment/message to Lab
47 N ORMSG S ORMSG(1)="BHS|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|LABORATORY|"_$G(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)
48 S ORMSG(2)=$$PID($G(PAT))
49 D MSG^XQOR("OR EVSEND LRCH",.ORMSG)
50 Q
51 ;
52BTS(PAT) ; -- Send batch trailer segment/message to Lab
53 N ORMSG S ORMSG(1)="BTS",ORMSG(2)=$$PID($G(PAT))
54 D MSG^XQOR("OR EVSEND LRCH",.ORMSG)
55 Q
56 ;
57MSH(TYPE,TO) ; -- MSH segment
58 N MSH
59 S MSH="MSH|^~\&|ORDER ENTRY|"_$G(DUZ(2))_"|"_$$NAME(TO)_"|"_$G(DUZ(2))_"|"_$$HL7DATE($$NOW^XLFDT)_"||"_TYPE
60 Q MSH
61 ;
62NAME(NMSP) ; -- Returns name of pkg NMSP
63 I NMSP="GMRA" Q "ALLERGIES"
64 I NMSP="GMRC" Q "CONSULTS"
65 I NMSP="FH" Q "DIETETICS"
66 I NMSP?1"LR".E Q "LABORATORY"
67 I NMSP="PS" Q "PHARMACY"
68 I NMSP="RA" Q "RADIOLOGY"
69 I NMSP="OR" Q "ORDER ENTRY"
70 Q ""
71 ;
72PID(DFN) ; -- PID segment
73 N PID,PTR,ROOT
74 S PTR=+$P(DFN,";"),ROOT=$P(DFN,";",2),PID="PID|||"
75 I ROOT="DPT(" S PID=PID_PTR_"||"_$P($G(^DPT(PTR,0)),U)
76 E S PID=PID_"|"_DFN_"|"_$S($L(ROOT):$P($G(@(U_ROOT_PTR_",0)")),U),1:"")
77 Q PID
78 ;
79PV1(OBJ,TYPE,LOC,VISIT,APPTDT) ; -- PV1 segment
80 N PV1,RB,PACH S RB=""
81 S:$G(APPTDT) APPTDT=$$FMTHL7^XLFDT(APPTDT)
82 I TYPE="I",+OBJ,$P(OBJ,";",2)="DPT(" S RB=$P($G(^DPT(+OBJ,.101)),U)
83 S PACH=$$PATCH^XPDUTL("PSJ*5.0*111")
84 S:PACH PV1="PV1||"_TYPE_"|"_LOC_$S($L(RB):U_RB,1:"")_"||||||||||||||||"_$G(VISIT)_"|||||||||||||||||||||||||"_$G(APPTDT)
85 S:'PACH PV1="PV1||"_TYPE_"|"_LOC_$S($L(RB):U_RB,1:"")_"||||||||||||||||"_$G(VISIT)
86 Q PV1
87 ;
88HL7DATE(DATE) ; -- FM -> HL7 format
89 Q $$FMTHL7^XLFDT(DATE) ;**97
90 ;
91USID(OI) ; -- Returns Univ Serv ID for Orderable Item
92 N OITEM,NATL,LOCAL S OITEM=$G(^ORD(101.43,+OI,0))
93 S NATL=$P(OITEM,U,3)_U_U_$P(OITEM,U,4)
94 S LOCAL=$P($P(OITEM,U,2),";")_U_$P(OITEM,U)_U_$P($P(OITEM,U,2),";",2)
95 Q NATL_U_LOCAL
96 ;
97NATURE(X) ; -- Returns 3 ^-piece identifier for nature X
98 N ORN,Y S ORN=$G(^ORD(100.02,+$G(X),0))
99 S Y=$P(ORN,U,2)_U_$P(ORN,U)_"^99ORN"
100 Q Y
101 ;
102REASON(X,N) ; -- Returns 6 ^-piece format of reason X
103 ; N ^ NATURE ^ 99ORN ^ # ^ Reason ^ 99ORR
104 N Y,ORR S ORR=$G(^ORD(100.03,+$G(X),0))
105 S:'$G(N) N=+$P(ORR,U,7) S Y=$$NATURE(N)
106 S:$G(X) Y=Y_U_$S(ORPKG'="RA":+X,1:"")_U_$P(ORR,U)_"^99ORR"
107 Q Y
108 ;
109IP() ; -- Returns ORIFN^Type if pt has active isolation order (or 0 if not)
110 N TYPE,START,ORIFN,Y
111 S TYPE=$O(^ORD(100.98,"B","PREC",0)),START=$$NOW^XLFDT,Y=0
112 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
113 I Y S TYPE=$$VALUE^ORCSAVE2(ORIFN,"ISOLATION"),Y=Y_U_$$GET1^DIQ(119.4,+TYPE_",",.01)
114 Q Y
115 ;
116OR ; -- new Generic order
117 I ORDG=$O(^ORD(100.98,"B","M.A.S.",0)) D ADT^ORMBLDOR Q
118 D EN^ORMBLDOR
119 Q
120 ;
121GMRA ; -- new Allergy order
122 Q:$$PATCH^XPDUTL("OR*3.0*216") ;195 quit if patch 216 is in
123 D:$L($T(ALG^ORMBLDAL)) ALG^ORMBLDAL
124 Q
125 ;
126GMRC ; -- new Consult order
127 D CSLT^ORMBLDGM
128 Q
129 ;
130FH ; -- new Diet order
131 N ORPARAM D EN^FHWOR8(+ORVP,.ORPARAM) ; set parameters
132 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T"
133 I ORDG=$O(^ORD(100.98,"B","PRECAUTIONS",0)) D IP^ORMBLDFH Q
134 I ORDG=$O(^ORD(100.98,"B","EARLY/LATE TRAYS",0)) D TRAY^ORMBLDFH Q
135 I ORDG=$O(^ORD(100.98,"B","TUBEFEEDINGS",0)) D TF^ORMBLDFH Q
136 I ORDG=$O(^ORD(100.98,"B","DIET ADDITIONAL ORDERS",0)) D ADDN^ORMBLDFH Q
137 D DIET^ORMBLDFH
138 Q
139 ;
140LR ; -- new Lab order
141 I CODE="XO" D XO^ORMBLDLR Q ; change
142 D CH^ORMBLDLR S ORPKG="LRCH" Q ;no difference by subscript at this time
143 N SUB S SUB=$P($G(^ORD(100.98,ORDG,0)),U,3)
144 S:(SUB="SP")!(SUB="EM")!(SUB="AU")!(SUB="CY") SUB="AP"
145 S:(SUB="LAB")!(SUB="MI")!(SUB="HEMA") SUB="CH"
146 D @(SUB_"^ORMBLDLR") S ORPKG=ORPKG_SUB
147 Q
148 ;
149PS ; -- new Pharmacy order
150 ;I ORDG=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0)) D OUT^ORMBLDPS Q
151 ;D UD^ORMBLDPS
152 N IVDLG S IVDLG=+$P(OR0,U,5) ;JD
153 N PKG S PKG=$P(OR0,U,14),PKG=$$GET1^DIQ(9.4,+PKG_",",1)
154 I +$$VALUE^ORCSAVE2(IFN,"URGENCY")=99,$P(OR3,U,11)'="B" D Q ;only send DONE orders from BCMA
155 . D STATUS^ORCSAVE2(IFN,2) K ORMSG
156 . 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
157 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))) D IV^ORMBLDPS Q
158 D @($S(PKG="PSIV":"IV",PKG="PSO":"OUT",PKG="PSH":"NVA",1:"UD")_"^ORMBLDPS")
159 Q
160 ;
161RA ; -- new Radiology order
162 D EN^ORMBLDRA
163 Q
164 ;
165TEST(ORIFN) ; -- Build/display HL7 msgs w/o sending
166 K ORZTEST S ORZTEST=1 D NEW(ORIFN) ; leaves msg in ORZTEST() on exit
167 Q
Note: See TracBrowser for help on using the repository browser.