source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m@ 1765

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1ORKLR ; slc/CLA - Order checking support procedure for lab orders ;7/23/96 14:31
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105**;Dec 17, 1997
3 Q
4DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info
5 N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL
6 ;get lab id from orderable item (OI):
7 S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)=""
8 ;expand into child-level lab identifiers if children exist for this OI:
9 ;if children found, set panel flag to '1':
10 S LRID="" F S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID="" S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1
11 ;get duplicate date range-beginning date/time for this OI:
12 S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U)
13 Q:DDT=0 ;if dup range for this OI = zero, don't process dup order oc
14 ;
15 ;get all lab orders since dup beg d/t:
16 S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN))
17 K ^TMP("ORR",$J)
18 D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0)
19 N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
20 S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1
21 F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D
22 .S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4)
23 .Q:+$G(ORN)=+$G(ORIFN) ;quit current order # = dup order #
24 .;break into child orders if they exist:
25 .I $D(^OR(100,ORN,2,0)) D ;child orders exist
26 ..S ORNC=0 F S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC="" D
27 ...Q:+$G(ORNC)=+$G(ORIFN) ;quit current order # = dup order #
28 ...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL))
29 .I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL))
30 K ^TMP("ORR",$J)
31 Q
32DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check
33 N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ
34 S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2)
35 ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed:
36 I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q
37 ;
38 ;get specimen for this order:
39 S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN")
40 Q:'$L($G(ORSP)) ;quit if no specimen found
41 ;get orderable item for this order:
42 S OROI=$$OI^ORQOR2(ORN)
43 Q:'$L($G(OROI)) ;quit if no orderable item found
44 ;get lab id and check against ordered array ORL
45 S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D
46 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDX D ;dup!
47 ..;
48 ..;quit if order results entered in lab as "cancelled":
49 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
50 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D
51 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
52 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab
53 ..;
54 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
55 ..;get most recent lab results:
56 ..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)
57 ..;
58 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
59 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*"
60 ;get children lab ids and check against ordered array ORL
61 S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D
62 .S LRIDXC=LRIDX_";"_ORSP
63 .S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup!
64 ..;
65 ..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
66 ..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D
67 ...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
68 ..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab
69 ..;
70 ..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
71 ..;get most recent lab results:
72 ..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP))
73 ..;
74 ..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
75 ..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*"
76 Q
77RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format:
78 ;test id^result units flag ref range collection d/t
79 N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE
80 Q:'$L($G(ORDFN)) "0^"
81 D NOW^%DTC
82 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
83 K %
84 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days
85 S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC")
86 Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test
87 Q:$G(LABFILE)'=60 "0^"
88 S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN")
89 Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec
90 Q:$G(SPECFILE)'=61 "0^"
91 F ORI=1:1:ORY I +$G(WBCRSLT)<1 D
92 .S TEST=$P(ORY(ORI),U)
93 .Q:+$G(TEST)<1
94 .F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D
95 ..S SPECIMEN=$P(ORX(ORJ),U)
96 ..Q:+$G(SPECIMEN)<1
97 ..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN)
98 ..Q:'$L($G(ORZ))
99 ..S CDT=$P(ORZ,U,7)
100 ..I CDT'<BDT S WBCRSLT=1
101 Q:+$G(WBCRSLT)<1 "0^"
102 Q $P(ORZ,U,3)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")
103 ;
104CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not
105 ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC
106 ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results
107 ;
108 N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF
109 Q:'$L($G(ORDFN)) "0^"
110 I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","")
111 S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days
112 ;
113 K LAB
114 D EN^PSODRG(ORCLOZ) ;pharmacy api rtns Lab file ptrs for WBC, ANC
115 Q:$G(LAB("NOT"))=0 "0^" ;medication is not clozapine
116 Q:$G(LAB("BAD TEST"))=0 "0^" ;one or both lab tests aren't mapped
117 S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U)
118 S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U)
119 ;
120 S WBCRSLT=$$LOCL^ORQQLR1(ORDFN,WBC,WBCSPEC)
121 S WBCCDT=$P(WBCRSLT,U,7)
122 S WBC=$P(WBCRSLT,U,3)
123 I $L(WBC) D
124 .S WBCRSLT="WBC: "_WBC_" ["_$$FMTE^XLFDT(WBCCDT,"""2P""")_"]"
125 E S WBCRSLT="WBC: no results found"
126 I $L(WBC),(WBCCDT>BDT) S WBCF=1
127 S:$G(WBCF)'=1 WBCF=0
128 ;
129 S ANCRSLT=$$LOCL^ORQQLR1(ORDFN,ANC,ANCSPEC)
130 S ANCCDT=$P(ANCRSLT,U,7)
131 S ANC=$P(ANCRSLT,U,3)
132 I $L(ANC),(ANCCDT=WBCCDT) D ;ANC from same collection d/t as WBC
133 .S ANC=(WBC*ANC)/100
134 .S ANCRSLT="ANC: "_ANC_" ["_$$FMTE^XLFDT(ANCCDT,"""2P""")_"]"
135 E S ANCRSLT="ANC: no results found"
136 I $L(ANC),(ANCCDT>BDT) S ANCF=1
137 S:$G(ANCF)'=1 ANCF=0
138 ;
139 K LAB
140 Q "1^"_WBCF_";"_WBC_"^"_ANCF_";"_ANC_"^"_WBCRSLT_" "_ANCRSLT
Note: See TracBrowser for help on using the repository browser.