ORKLR ; slc/CLA - Order checking support procedure for lab orders ;10-Oct-2013 18:02;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105,243,1012**;Dec 17, 1997;Build 242
; Modified - IHS/MSC/MGH - 10/09/2013 - Line CLOZLABS+17
Q
DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info
N ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL
;get lab id from orderable item (OI):
S LRID=$P(^ORD(101.43,OI,0),U,2) S:$L($G(LRID)) ORL(LRID_";"_SPECIMEN)=""
;expand into child-level lab identifiers if children exist for this OI:
;if children found, set panel flag to '1':
S LRID="" F S LRID=$O(^ORD(101.43,OI,10,"AID",LRID)) Q:LRID="" S ORL(LRID_";"_SPECIMEN)="",ORPANEL=1
;get duplicate date range-beginning date/time for this OI:
S DDT=$P($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U)
Q:DDT=0 ;if dup range for this OI = zero, don't process dup order oc
;
;get all lab orders since dup beg d/t:
S DGIEN=0,DGIEN=$O(^ORD(100.98,"B","LAB",DGIEN))
K ^TMP("ORR",$J)
D EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0)
N J,HOR,SEQ,X S J=1,HOR=0,SEQ=0
S HOR=$O(^TMP("ORR",$J,HOR)) Q:+HOR<1
F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D
.S X=^TMP("ORR",$J,HOR,SEQ),ORN=+$P(X,U),ODT=$P(X,U,4)
.Q:+$G(ORN)=+$G(ORIFN) ;quit current order # = dup order #
.;break into child orders if they exist:
.I $D(^OR(100,ORN,2,0)) D ;child orders exist
..S ORNC=0 F S ORNC=$O(^OR(100,ORN,2,ORNC)) Q:ORNC="" D
...Q:+$G(ORNC)=+$G(ORIFN) ;quit current order # = dup order #
...D DUP2(.ORKLR,ORNC,ODT,.ORL,$G(ORPANEL))
.I '$D(^OR(100,ORN,2,0)) D DUP2(.ORKLR,ORN,ODT,.ORL,$G(ORPANEL))
K ^TMP("ORR",$J)
Q
DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check
N ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ
S ORS=$$STATUS^ORQOR2(ORN),ORSI=$P(ORS,U),ORST=$P(ORS,U,2)
;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed:
I (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10) Q
;
;get specimen for this order:
S ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN")
Q:'$L($G(ORSP)) ;quit if no specimen found
;get orderable item for this order:
S OROI=$$OI^ORQOR2(ORN)
Q:'$L($G(OROI)) ;quit if no orderable item found
;get lab id and check against ordered array ORL
S:$L($G(^ORD(101.43,OROI,0))) LRIDX=$P(^ORD(101.43,OROI,0),U,2)_";"_ORSP I $L($G(LRIDX)) D
.S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDX D ;dup!
..;
..;quit if order results entered in lab as "cancelled":
..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D
...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab
..;
..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
..;get most recent lab results:
..S RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)
..;
..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*"
;get children lab ids and check against ordered array ORL
S LRIDX="" F S LRIDX=$O(^ORD(101.43,OROI,10,"AID",LRIDX)) Q:LRIDX="" D
.S LRIDXC=LRIDX_";"_ORSP
.S LRID="" F S LRID=$O(ORL(LRID)) Q:LRID="" I LRID=LRIDXC D ;dup!
..;
..D ORDER^ORQQLR(.ORY,ORDFN,ORN)
..S ORX=0 F S ORX=$O(ORY(ORX)) Q:+$G(ORX)<1 D
...I ($P(LRID,";")=$P(ORY(ORX),U)),($P(ORY(ORX),U,3)["canc") S ORQ=1
..Q:+$G(ORQ)=1 ;quit if lab test cancelled in lab
..;
..S EXDT=$$FMTE^XLFDT(ODT,"2P"),INVDT=9999999-ODT
..;get most recent lab results:
..S RCNT=$S($G(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP))
..;
..S ORKLR(INVDT)=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(EXDT)_" ["_$S(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
..I +RCNT>0 S ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$P(RCNT,U,2)_"*"
Q
RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format:
;test id^result units flag ref range collection d/t
N BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE
Q:'$L($G(ORDFN)) "0^"
D NOW^%DTC
I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
K %
S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days
S LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC")
Q:'$D(ORY) "0^" ;quit if no link between WBC and local lab test
Q:$G(LABFILE)'=60 "0^"
S SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN")
Q:'$D(ORX) "0^" ;quit if no link between BLOOD SPECIMEN and local spec
Q:$G(SPECFILE)'=61 "0^"
F ORI=1:1:ORY I +$G(WBCRSLT)<1 D
.S TEST=$P(ORY(ORI),U)
.Q:+$G(TEST)<1
.F ORJ=1:1:ORX I +$G(WBCRSLT)<1 D
..S SPECIMEN=$P(ORX(ORJ),U)
..Q:+$G(SPECIMEN)<1
..S ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN)
..Q:'$L($G(ORZ))
..S CDT=$P(ORZ,U,7)
..I CDT'<BDT S WBCRSLT=1
Q:+$G(WBCRSLT)<1 "0^"
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")
;
CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not
;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC
; result^recent ANC flag;recent ANC result^formatted WBC and ANC results
;
N BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF
Q:'$L($G(ORDFN)) "0^"
I $L($G(ORDAYS)) S BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","")
S:'$L($G(BDT)) BDT=1 ;if no ORDAYS, set BDT to '1' to search all days
;
K LAB
D EN^PSODRG(ORCLOZ) ;pharmacy api rtns Lab file ptrs for WBC, ANC
Q:$G(LAB("NOT"))=0 "0^" ;medication is not clozapine
;Q:$G(LAB("BAD TEST"))=0 "0^" ;one or both lab tests aren't mapped
;S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U)
;S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U)
;
K ^TMP($J,"PSO")
;IHS/MSC/MGH Patch 1012
;D CL1^YSCLTST2(ORDFN,ORDAYS)
I $D(^TMP($J,"PSO")) D
.N INVDT
.S INVDT=$O(^TMP($J,"PSO",0))
.Q:'INVDT
.S WBC=$P($G(^TMP($J,"PSO",INVDT)),U)/1000
.S ANC=$P($G(^TMP($J,"PSO",INVDT)),U,2)/1000
.I WBC S WBCF=1
.I ANC S ANCF=1
.I $L(WBC)=1 S WBC=WBC_".0"
.I $L(ANC)=1 S ANC=ANC_".0"
.S WBCRSLT="WBC "_WBC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
.S ANCRSLT="ANC "_ANC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
;
K LAB
Q "1^"_$G(WBCF,0)_";"_$G(WBC)_"^"_$G(ANCF,0)_";"_$G(ANC)_"^"_$G(WBCRSLT)_" "_$G(ANCRSLT)
ORKLR ; slc/CLA - Order checking support procedure for lab orders ;10-Oct-2013 18:02;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,51,92,105,243,1012**;Dec 17, 1997;Build 242
+2 ; Modified - IHS/MSC/MGH - 10/09/2013 - Line CLOZLABS+17
+3 QUIT
DUP(ORKLR,OI,ORDFN,NEWORDT,SPECIMEN) ; return duplicate lab order info
+1 NEW ORL,DDT,ODT,ORN,ORNC,LRID,DGIEN,ORPANEL
+2 ;get lab id from orderable item (OI):
+3 SET LRID=$PIECE(^ORD(101.43,OI,0),U,2)
IF $LENGTH($GET(LRID))
SET ORL(LRID_";"_SPECIMEN)=""
+4 ;expand into child-level lab identifiers if children exist for this OI:
+5 ;if children found, set panel flag to '1':
+6 SET LRID=""
FOR
SET LRID=$ORDER(^ORD(101.43,OI,10,"AID",LRID))
IF LRID=""
QUIT
SET ORL(LRID_";"_SPECIMEN)=""
SET ORPANEL=1
+7 ;get duplicate date range-beginning date/time for this OI:
+8 SET DDT=$PIECE($$DUPRANGE^ORQOR2(OI,"LR",NEWORDT,ORDFN),U)
+9 ;if dup range for this OI = zero, don't process dup order oc
IF DDT=0
QUIT
+10 ;
+11 ;get all lab orders since dup beg d/t:
+12 SET DGIEN=0
SET DGIEN=$ORDER(^ORD(100.98,"B","LAB",DGIEN))
+13 KILL ^TMP("ORR",$JOB)
+14 DO EN^ORQ1(ORDFN_";DPT(",DGIEN,1,"",DDT,NEWORDT,1,0)
+15 NEW J,HOR,SEQ,X
SET J=1
SET HOR=0
SET SEQ=0
+16 SET HOR=$ORDER(^TMP("ORR",$JOB,HOR))
IF +HOR<1
QUIT
+17 FOR
SET SEQ=$ORDER(^TMP("ORR",$JOB,HOR,SEQ))
IF +SEQ<1
QUIT
Begin DoDot:1
+18 SET X=^TMP("ORR",$JOB,HOR,SEQ)
SET ORN=+$PIECE(X,U)
SET ODT=$PIECE(X,U,4)
+19 ;quit current order # = dup order #
IF +$GET(ORN)=+$GET(ORIFN)
QUIT
+20 ;break into child orders if they exist:
+21 ;child orders exist
IF $DATA(^OR(100,ORN,2,0))
Begin DoDot:2
+22 SET ORNC=0
FOR
SET ORNC=$ORDER(^OR(100,ORN,2,ORNC))
IF ORNC=""
QUIT
Begin DoDot:3
+23 ;quit current order # = dup order #
IF +$GET(ORNC)=+$GET(ORIFN)
QUIT
+24 DO DUP2(.ORKLR,ORNC,ODT,.ORL,$GET(ORPANEL))
End DoDot:3
End DoDot:2
+25 IF '$DATA(^OR(100,ORN,2,0))
DO DUP2(.ORKLR,ORN,ODT,.ORL,$GET(ORPANEL))
End DoDot:1
+26 KILL ^TMP("ORR",$JOB)
+27 QUIT
DUP2(ORKLR,ORN,ODT,ORL,ORPANEL) ;second part of dup lab order check
+1 NEW ORS,ORST,ORSI,ORSP,OROI,LRID,LRIDX,LRIDXC,EXDT,INVDT,RCNT,ORY,ORX,ORQ
+2 SET ORS=$$STATUS^ORQOR2(ORN)
SET ORSI=$PIECE(ORS,U)
SET ORST=$PIECE(ORS,U,2)
+3 ;quit if order status is canceled/discontinued/expired/lapsed/changed/delayed:
+4 IF (ORSI=13)!(ORSI=1)!(ORSI=7)!(ORSI=14)!(ORSI=12)!(ORSI=10)
QUIT
+5 ;
+6 ;get specimen for this order:
+7 SET ORSP=$$VALUE^ORCSAVE2(ORN,"SPECIMEN")
+8 ;quit if no specimen found
IF '$LENGTH($GET(ORSP))
QUIT
+9 ;get orderable item for this order:
+10 SET OROI=$$OI^ORQOR2(ORN)
+11 ;quit if no orderable item found
IF '$LENGTH($GET(OROI))
QUIT
+12 ;get lab id and check against ordered array ORL
+13 IF $LENGTH($GET(^ORD(101.43,OROI,0)))
SET LRIDX=$PIECE(^ORD(101.43,OROI,0),U,2)_";"_ORSP
IF $LENGTH($GET(LRIDX))
Begin DoDot:1
+14 ;dup!
SET LRID=""
FOR
SET LRID=$ORDER(ORL(LRID))
IF LRID=""
QUIT
IF LRID=LRIDX
Begin DoDot:2
+15 ;
+16 ;quit if order results entered in lab as "cancelled":
+17 DO ORDER^ORQQLR(.ORY,ORDFN,ORN)
+18 SET ORX=0
FOR
SET ORX=$ORDER(ORY(ORX))
IF +$GET(ORX)<1
QUIT
Begin DoDot:3
+19 IF ($PIECE(LRID,";")=$PIECE(ORY(ORX),U))
IF ($PIECE(ORY(ORX),U,3)["canc")
SET ORQ=1
End DoDot:3
+20 ;quit if lab test cancelled in lab
IF +$GET(ORQ)=1
QUIT
+21 ;
+22 SET EXDT=$$FMTE^XLFDT(ODT,"2P")
SET INVDT=9999999-ODT
+23 ;get most recent lab results:
+24 SET RCNT=$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP)
+25 ;
+26 SET ORKLR(INVDT)=ORN_U_$PIECE($$TEXT^ORKOR(ORN,60),U,2)_" "_$GET(EXDT)_" ["_$SELECT(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
+27 IF +RCNT>0
SET ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$PIECE(RCNT,U,2)_"*"
End DoDot:2
End DoDot:1
+28 ;get children lab ids and check against ordered array ORL
+29 SET LRIDX=""
FOR
SET LRIDX=$ORDER(^ORD(101.43,OROI,10,"AID",LRIDX))
IF LRIDX=""
QUIT
Begin DoDot:1
+30 SET LRIDXC=LRIDX_";"_ORSP
+31 ;dup!
SET LRID=""
FOR
SET LRID=$ORDER(ORL(LRID))
IF LRID=""
QUIT
IF LRID=LRIDXC
Begin DoDot:2
+32 ;
+33 DO ORDER^ORQQLR(.ORY,ORDFN,ORN)
+34 SET ORX=0
FOR
SET ORX=$ORDER(ORY(ORX))
IF +$GET(ORX)<1
QUIT
Begin DoDot:3
+35 IF ($PIECE(LRID,";")=$PIECE(ORY(ORX),U))
IF ($PIECE(ORY(ORX),U,3)["canc")
SET ORQ=1
End DoDot:3
+36 ;quit if lab test cancelled in lab
IF +$GET(ORQ)=1
QUIT
+37 ;
+38 SET EXDT=$$FMTE^XLFDT(ODT,"2P")
SET INVDT=9999999-ODT
+39 ;get most recent lab results:
+40 SET RCNT=$SELECT($GET(ORPANEL)=1:"",1:$$LOCLFORM^ORQQLR1(ORDFN,+LRID,ORSP))
+41 ;
+42 SET ORKLR(INVDT)=ORN_U_$PIECE($$TEXT^ORKOR(ORN,60),U,2)_" "_$GET(EXDT)_" ["_$SELECT(ORST="COMPLETE":"COLLECTED",ORST="PENDING":"UNCOLLECTED",1:ORST)_"]"
+43 IF +RCNT>0
SET ORKLR(INVDT)=ORKLR(INVDT)_" *Most recent result: "_$PIECE(RCNT,U,2)_"*"
End DoDot:2
End DoDot:1
+44 QUIT
RECNTWBC(ORDFN,ORDAYS) ;extrinsic function to return most recent WBC within <ORDAYS> in format:
+1 ;test id^result units flag ref range collection d/t
+2 NEW BDT,CDT,ORY,ORX,ORZ,X,TEST,ORI,ORJ,WBCRSLT,LABFILE,SPECFILE
+3 IF '$LENGTH($GET(ORDFN))
QUIT "0^"
+4 DO NOW^%DTC
+5 IF $LENGTH($GET(ORDAYS))
SET BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
+6 KILL %
+7 ;if no ORDAYS, set BDT to '1' to search all days
IF '$LENGTH($GET(BDT))
SET BDT=1
+8 SET LABFILE=$$TERMLKUP^ORB31(.ORY,"WBC")
+9 ;quit if no link between WBC and local lab test
IF '$DATA(ORY)
QUIT "0^"
+10 IF $GET(LABFILE)'=60
QUIT "0^"
+11 SET SPECFILE=$$TERMLKUP^ORB31(.ORX,"BLOOD SPECIMEN")
+12 ;quit if no link between BLOOD SPECIMEN and local spec
IF '$DATA(ORX)
QUIT "0^"
+13 IF $GET(SPECFILE)'=61
QUIT "0^"
+14 FOR ORI=1:1:ORY
IF +$GET(WBCRSLT)<1
Begin DoDot:1
+15 SET TEST=$PIECE(ORY(ORI),U)
+16 IF +$GET(TEST)<1
QUIT
+17 FOR ORJ=1:1:ORX
IF +$GET(WBCRSLT)<1
Begin DoDot:2
+18 SET SPECIMEN=$PIECE(ORX(ORJ),U)
+19 IF +$GET(SPECIMEN)<1
QUIT
+20 SET ORZ=$$LOCL^ORQQLR1(ORDFN,TEST,SPECIMEN)
+21 IF '$LENGTH($GET(ORZ))
QUIT
+22 SET CDT=$PIECE(ORZ,U,7)
+23 IF CDT'<BDT
SET WBCRSLT=1
End DoDot:2
End DoDot:1
+24 IF +$GET(WBCRSLT)<1
QUIT "0^"
+25 QUIT $PIECE(ORZ,U,3)_U_$PIECE(ORZ,U,3)_" "_$PIECE(ORZ,U,4)_" "_$PIECE(ORZ,U,5)_" ("_$PIECE(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")
+26 ;
CLOZLABS(ORDFN,ORDAYS,ORCLOZ) ;extrinsic function rtns "1" if clozapine ordered and WBC labs results within past ORDAYS, "0" if not
+1 ;result format: clozapine/mapped labs flag^recent WBC flag;recent WBC
+2 ; result^recent ANC flag;recent ANC result^formatted WBC and ANC results
+3 ;
+4 NEW BDT,WBC,WBCSPEC,WBCRSLT,WBCCDT,WBCF,ANC,ANCSPEC,ANCRSLT,ANCCDT,ANCF
+5 IF '$LENGTH($GET(ORDFN))
QUIT "0^"
+6 IF $LENGTH($GET(ORDAYS))
SET BDT=$$FMADD^XLFDT($$NOW^XLFDT,"-"_ORDAYS,"","","")
+7 ;if no ORDAYS, set BDT to '1' to search all days
IF '$LENGTH($GET(BDT))
SET BDT=1
+8 ;
+9 KILL LAB
+10 ;pharmacy api rtns Lab file ptrs for WBC, ANC
DO EN^PSODRG(ORCLOZ)
+11 ;medication is not clozapine
IF $GET(LAB("NOT"))=0
QUIT "0^"
+12 ;Q:$G(LAB("BAD TEST"))=0 "0^" ;one or both lab tests aren't mapped
+13 ;S WBC=$G(LAB("WBC")),WBCSPEC=$P(WBC,U,2),WBC=$P(WBC,U)
+14 ;S ANC=$G(LAB("ANC")),ANCSPEC=$P(ANC,U,2),ANC=$P(ANC,U)
+15 ;
+16 KILL ^TMP($JOB,"PSO")
+17 ;IHS/MSC/MGH Patch 1012
+18 ;D CL1^YSCLTST2(ORDFN,ORDAYS)
+19 IF $DATA(^TMP($JOB,"PSO"))
Begin DoDot:1
+20 NEW INVDT
+21 SET INVDT=$ORDER(^TMP($JOB,"PSO",0))
+22 IF 'INVDT
QUIT
+23 SET WBC=$PIECE($GET(^TMP($JOB,"PSO",INVDT)),U)/1000
+24 SET ANC=$PIECE($GET(^TMP($JOB,"PSO",INVDT)),U,2)/1000
+25 IF WBC
SET WBCF=1
+26 IF ANC
SET ANCF=1
+27 IF $LENGTH(WBC)=1
SET WBC=WBC_".0"
+28 IF $LENGTH(ANC)=1
SET ANC=ANC_".0"
+29 SET WBCRSLT="WBC "_WBC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
+30 SET ANCRSLT="ANC "_ANC_" ["_$$FMTE^XLFDT(9999999-INVDT,"""2P""")_"]"
End DoDot:1
+31 ;
+32 KILL LAB
+33 QUIT "1^"_$GET(WBCF,0)_";"_$GET(WBC)_"^"_$GET(ANCF,0)_";"_$GET(ANC)_"^"_$GET(WBCRSLT)_" "_$GET(ANCRSLT)
