- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKLR.m
r613 r623 1 ORKLR ; 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,243**;Dec 17, 1997;Build 242 3 Q 4 DUP(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 32 DUP2(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 77 RECNTWBC(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 ; 104 CLOZLABS(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 K ^TMP($J,"PSO") 121 D CL1^YSCLTST2(ORDFN,ORDAYS) 122 I $D(^TMP($J,"PSO")) D 123 .N INVDT 124 .S INVDT=$O(^TMP($J,"PSO",0)) 125 .Q:'INVDT 126 .S WBC=$P($G(^TMP($J,"PSO",INVDT)),U)/1000 127 .S ANC=$P($G(^TMP($J,"PSO",INVDT)),U,2)/1000 128 .I WBC S WBCF=1 129 .I ANC S ANCF=1 130 .I $L(WBC)=1 S WBC=WBC_".0" 131 .I $L(ANC)=1 S ANC=ANC_".0" 132 .S WBCRSLT="WBC "_WBC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]" 133 .S ANCRSLT="ANC "_ANC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]" 134 ; 135 K LAB 136 Q "1^"_$G(WBCF,0)_";"_$G(WBC)_"^"_$G(ANCF,0)_";"_$G(ANC)_"^"_$G(WBCRSLT)_" "_$G(ANCRSLT) 1 ORKLR ; 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 4 DUP(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 32 DUP2(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 77 RECNTWBC(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 ; 104 CLOZLABS(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 TracChangeset
for help on using the changeset viewer.
