VPRSDAB ;SLC/MKB -- SDA Lab utilities ;4/11/19 21:05
;;1.0;VIRTUAL PATIENT RECORD;**20,26,27,31,35**;Sep 01, 2011;Build 16
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DDE 7008
; ^LAB(60 10054
; ^LR 525
; ^OR(100 5771
; ^ORD(100.98 6982
; ^ORD(101.43 2843
; DIC 2051
; DIQ 2056
; LR7OR1, ^TMP("LRRR",$J 2503
; LR7OSUM, ^TMP("LR"*,$J 2766
; LR7OU1 2955
; LRPXAPIU 4246
; ORQ1, ^TMP("ORR",$J) 3154
; ORX8 2467,3071
;
ORDERS ; -- Return DLIST(#)=order# of Lab orders
; Includes VBECS/BB orders [not in use yet]
; Expects DFN, DSTRT,DSTOP, DMAX
N ORDG,VBECS,ORIGVIEW,ORKID,ORLIST,VPRI,VPRN,ORDER,X0,X3
S ORDG=+$O(^ORD(100.98,"B","LAB",0))
S VBECS=+$$FIND1^DIC(9.4,,"QX","VBEC","C")
; return original view, child orders
S ORIGVIEW=2,ORKID=1
D EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP,,,,1) S VPRN=0
S VPRI=0 F S VPRI=$O(^TMP("ORR",$J,ORLIST,VPRI)) Q:VPRI<1 S ORDER=$G(^(VPRI)) D Q:VPRN'<DMAX
. I $P($P(ORDER,U),";",2)>1 Q ;skip order actions
. S ORDER=+ORDER,X0=$G(^OR(100,ORDER,0)),X3=$G(^(3))
. Q:$P(X3,U,3)=13 Q:$P(X3,U,3)=14 ;cancelled or lapsed
. ; only VBECS parent orders, to get to veiled child orders
. I $O(^OR(100,ORDER,2,0)) Q:$P(X0,U,14)'=VBECS D Q
.. S ORKID=0 F S ORKID=$O(^OR(100,ORDER,2,ORKID)) Q:ORKID<1 D
... Q:$P($G(^OR(100,ORKID,0)),U,14)'=VBECS ;VBECS child orders
... S VPRN=VPRN+1,DLIST(VPRN)=ORKID
. I $P(X3,U,9),$P($G(^OR(100,+$P(X3,U,9),0)),U,14)=VBECS Q
. S VPRN=VPRN+1,DLIST(VPRN)=ORDER
K ^TMP("ORR",$J)
Q
;
ONE(ID) ; -- ID processing for Lab order returns: [not in use yet]
; ORPK = Lab order/data string
; ORDAD = parent order#
; VPRCDT = Lab collection (start) date.time
; VPRVBEC = 1 or 0, if VBECS order
; ORLAB = associated Lab child order#, if VBECS
;
S ID=+$G(ID) Q:ID<1 S ORLAB=""
S VPRCDT=$P($G(^OR(100,ID,0)),U,8),ORDAD=$P($G(^(3)),U,9),ORPK=$G(^(4))
S VPRVBEC=$$VB(ID) I VPRVBEC D Q ;get lab child#
. S ORLAB=$$VALUE^ORX8(ID,"LAB") I 'ORLAB S DDEOUT=1 Q
. S VPRCDT=$P($G(^OR(100,ORLAB,0)),U,8),ORPK=$G(^(4))
Q
;
VB(ORIFN) ; -- return 1 or 0, if order is for Blood Bank
N X,Y,DG S Y=0
S X=$P($G(^OR(100,+$G(ORIFN),0)),U,11),DG=$P($G(^ORD(100.98,+X,0)),U,3)
I DG?1"VB".E S Y=1
Q Y
;
DG(DG) ; -- convert DG to section, if needed
; Returns LRSUB = DG abbreviation
N X,Y S X="",Y=0 D ;get LR section
. S X=$P($G(ORPK),";",4) Q:$L(X)
. S X=$P($G(^ORD(101.43,+$G(ORIT),"LR")),U,6) Q:$L(X)
. I $G(VPRVBEC) S X="VBEC"
I X'="" S Y=$O(^ORD(100.98,"B",X,0)) S:Y DG=Y
S LRSUB=$P($G(^ORD(100.98,+$G(DG),0)),U,3)
Q
;
LRDFN(ORIFN) ; -- set up LRDFN for Lab Order
I '$G(DFN),$G(ORIFN) S DFN=+$$GET1^DIQ(100,+ORIFN_",",.02,"I")
S LRDFN=$S($G(DFN):$$LRDFN^LRPXAPIU(DFN),1:0)
Q
;
RSLT ; -- get Entity for LabOrder Result
; Returns VALUE, ENTITY, DATA
N SUB,IDT S SUB=$S($G(VPRVBEC):"BB",1:$G(LRSUB))
I SUB="BB" S DDEOUT=1 Q ;for now
S IDT=$P($G(ORPK),";",5) S:'IDT IDT=9999999-$G(VPRCDT)
S VALUE=IDT_","_+$G(LRDFN),ENTITY="VPR LR"_SUB_" RESULT"
S ENTITY=+$O(^DDE("B",ENTITY,0)) I ENTITY<1 S DDEOUT=1 Q
S DATA=+$P($G(ORIT),U,3) ;#60 ien ordered
Q
;
CH(TEST) ; -- builds DLIST(#) of result nodes for TEST
; called from ResultItems in VPR LRCH RESULT, expects DIEN
Q:'$P($G(LR0),U,3) ;only return final results
N T,X S TEST=+$G(TEST)
D EXPAND^LR7OU1(TEST,.DLIST)
S T=0 F S T=$O(DLIST(T)) Q:T<1 D
. S X=$P($G(^LAB(60,T,0)),U,3) I X'="O",X'="B" Q ;not displayable
. ; DLIST(60 ien) = CH data node#,LRIDT,LRDFN
. S DLIST(T)=$$LRDN^LRPXAPIU(T)_","_DIEN
Q
;
VALRNG(LOW,HIGH) ; -- Validate that range values will be accepted in SDA format for <ResultNormalRange> post REFRNG execution
;LOW - Range low value
;HIGH - range high value
;RESULT - Ture/False value, will pass or fail SDA <ResultNormalRnage> format
N RESULT
S RESULT=1
S LOW=$G(LOW),HIGH=$G(HIGH)
;Strip any surrounding quotes
I LOW?1"""".E1"""" S LOW=$E(LOW,2,$L(LOW)-1)
I HIGH?1"""".E1"""" S HIGH=$E(HIGH,2,$L(HIGH)-1)
;If both parameters are defined, we have a ##-## range and the first character of LOW and HIGH must be numeric.
I LOW'="",(HIGH'="") D
.I $E(LOW)'?1N,($E(LOW,1,2)'?1"."1N) S RESULT=0
.I $E(HIGH)'?1N,($E(HIGH,1,2)'?1"."1N) S RESULT=0
Q RESULT
;
REFRNG(RLV,RHV) ; -- format low-high ref range string
;RLV - Range low value
;RHV - Range high value
;Based on supported EN^LRLRRVF
S RLV=$G(RLV),RHV=$G(RHV)
I RLV="",RHV="" Q RLV
;Strip any surrounding quotes
I RLV?1"""".E1"""" S RLV=$E(RLV,2,$L(RLV)-1)
I RHV?1"""".E1"""" S RHV=$E(RHV,2,$L(RHV)-1)
;If only the low is defined
I RLV'="",RHV="" D Q RLV
. I RLV=0 S RLV=">"_RLV Q
. I ($E(RLV)="<")!($E(RLV)=">") Q ;ok
. I (RLV?.N.".".N) S RLV=">"_RLV Q ;numeric
. ;else return RLV as is (non-numeric)
;If only the high is defined
I RLV="",RHV'="" D Q RHV
. I RHV=0 S RHV="<"_RHV Q
. I ($E(RHV)="<")!($E(RHV)=">") Q ;ok
. I (RHV?.N.".".N) S RHV="<"_RHV Q ;numeric
. S RHV="-"_RHV
;If both are defined
Q RLV_"-"_RHV
;
MI1(D0,D1) ; -- return MI approval node
N GBL,N,X,Y
S D0=+$G(D0),D1=+$G(D1),GBL=$NA(^LR(D0,"MI",D1)),Y=""
F N=1,5,8,11,16 S X=$G(@GBL@(N)) I X,$P(X,U,2)="F" D Q
. S Y=$P(X,U,1,2)_U_$S(N=11:$P(X,U,5),1:$P(X,U,3))
Q Y
;
APRPTS ; -- Anatomic Pathology reports query [from DDEGET]
; Expects DFN, DSTRT,DSTOP, DMAX, LRDFN
; Return DLIST(#) = IDT,LRDFN~SUB
N SUB,IDT,VPRN,CTR S VPRN=0
D RR^LR7OR1(DFN,,DSTRT,DSTOP,"AP")
S SUB="" F S SUB=$O(^TMP("LRRR",$J,DFN,SUB)) Q:SUB="" D
. S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 I $O(^(IDT,0)) D Q:VPRN'<DMAX
.. Q:$O(^LR(LRDFN,SUB,IDT,.05,0)) ;report in TIU
.. Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11) ;not final results
.. S VPRN=VPRN+1,DLIST(VPRN)=IDT_","_LRDFN_"~"_SUB
K ^TMP("LRRR",$J,DFN)
Q
;
MIRPTS ; -- Microbiology reports query [from DDEGET]
; Expects DFN, DSTRT,DSTOP, DMAX, LRDFN
; Return DLIST(#) = IDT,LRDFN~SUB
N IDT,VPRN,CTR S VPRN=0
D RR^LR7OR1(DFN,,DSTRT,DSTOP,"MI")
S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"MI",IDT)) Q:IDT<1 I $O(^(IDT,0)) D Q:VPRN'<DMAX
. ;Q:'$P($G(^LR(LRDFN,"MI",IDT,0)),U,3) ;not final results
. Q:'$$MI1^VPRSDAB(LRDFN,IDT) ;not final results
. S VPRN=VPRN+1,DLIST(VPRN)=IDT_","_LRDFN_"~MI"
K ^TMP("LRRR",$J,DFN)
Q
;
AP1(ID) ; -- parse ID='IDT,LRDFN~SUB' for AP,MI report
; Returns DIFN, LRSUB, updated ID, LR0=^LR(LRDFN,SUB,IDT,0)
; and LR1=^LR(LRDFN,"MI",IDT,#) report approval if MI
S ID=$G(ID),LRSUB=$P(ID,"~",2),ID=$P(ID,"~")
I LRSUB D ;sub-file#
. S DIFN=LRSUB,LRSUB=$S(DIFN=63.05:"MI",DIFN=63.09:"CY",DIFN=63.02:"EM",DIFN=63.08:"SP",1:"AP")
E S DIFN=$S(LRSUB="MI":63.05,LRSUB="CY":63.09,LRSUB="EM":63.02,LRSUB="SP":63.08,1:0)
I DIFN<1 S DDEOUT=1 Q
S:'$G(LRDFN) LRDFN=+$P(ID,",",2)
S LR0=$G(^LR(LRDFN,LRSUB,+ID,0))
I LRSUB="MI" S LR1=$$MI1(LRDFN,+ID)
Q
;
RR ; -- returns addl reports for order in DLIST(#) = IDT;SUB or IEN;TIU
; Expects DFN, ORPK, LRDFN
N SUB,IDT,X,CNT
Q:$G(DFN)<1 Q:$P($G(ORPK),";",4)=""
D RR^LR7OR1(DFN,ORPK)
S SUB=$P(ORPK,";",4),CNT=0
S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D
. Q:$P(ORPK,";",5)=IDT ;returned in Result.DocumentNumber
. I SUB="MI" Q:'$$MI1(LRDFN,IDT) S X=IDT_";MI"
. I SUB'="MI" Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11) S X=$$LRTIU(SUB,IDT)
. S CNT=CNT+1,DLIST(CNT)=X
Q
;
LRTIU(IDT,SUB) ; -- return TIU ien of lab report
N I,IEN,X,Y
S IDT=$G(IDT),SUB=$G(SUB),Y=IDT_";"_SUB
S I=0 F S I=$O(^LR(LRDFN,SUB,IDT,.05,I)) Q:I<1 S IEN=+$P($G(^(I,0)),U,2),X=+$$GET1^DIQ(8925,IEN,.05,"I") I (X=7)!(X=8) S Y=IEN_";TIU" Q
Q Y
;
RPT(SUB,IDT) ; -- return report text in WP(), expects DFN
N I,DATE,NAME,VPRS,VPRY,X,LRAU
N LRSUB,TAG,FILE,FIELD,IEN ;protect
K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
S DATE=9999999-+$G(IDT),NAME=$S(SUB="EM":"EM",1:$$NAME^VPRDLRA(SUB)),VPRS(NAME)=""
D EN^LR7OSUM(.VPRY,DFN,DATE,DATE,,,.VPRS)
S I=+$G(^TMP("LRH",$J,NAME)) ;LRH=header
F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=$G(^(I,0)) Q:X?1."=" S WP(I)=X
K ^TMP("LRC",$J),^TMP("LRH",$J),^TMP("LRT",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAB 8504 printed Sep 23, 2025@20:22:08 Page 2
VPRSDAB ;SLC/MKB -- SDA Lab utilities ;4/11/19 21:05
+1 ;;1.0;VIRTUAL PATIENT RECORD;**20,26,27,31,35**;Sep 01, 2011;Build 16
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DDE 7008
+7 ; ^LAB(60 10054
+8 ; ^LR 525
+9 ; ^OR(100 5771
+10 ; ^ORD(100.98 6982
+11 ; ^ORD(101.43 2843
+12 ; DIC 2051
+13 ; DIQ 2056
+14 ; LR7OR1, ^TMP("LRRR",$J 2503
+15 ; LR7OSUM, ^TMP("LR"*,$J 2766
+16 ; LR7OU1 2955
+17 ; LRPXAPIU 4246
+18 ; ORQ1, ^TMP("ORR",$J) 3154
+19 ; ORX8 2467,3071
+20 ;
ORDERS ; -- Return DLIST(#)=order# of Lab orders
+1 ; Includes VBECS/BB orders [not in use yet]
+2 ; Expects DFN, DSTRT,DSTOP, DMAX
+3 NEW ORDG,VBECS,ORIGVIEW,ORKID,ORLIST,VPRI,VPRN,ORDER,X0,X3
+4 SET ORDG=+$ORDER(^ORD(100.98,"B","LAB",0))
+5 SET VBECS=+$$FIND1^DIC(9.4,,"QX","VBEC","C")
+6 ; return original view, child orders
+7 SET ORIGVIEW=2
SET ORKID=1
+8 DO EN^ORQ1(DFN_";DPT(",ORDG,6,,DSTRT,DSTOP,,,,1)
SET VPRN=0
+9 SET VPRI=0
FOR
SET VPRI=$ORDER(^TMP("ORR",$JOB,ORLIST,VPRI))
if VPRI<1
QUIT
SET ORDER=$GET(^(VPRI))
Begin DoDot:1
+10 ;skip order actions
IF $PIECE($PIECE(ORDER,U),";",2)>1
QUIT
+11 SET ORDER=+ORDER
SET X0=$GET(^OR(100,ORDER,0))
SET X3=$GET(^(3))
+12 ;cancelled or lapsed
if $PIECE(X3,U,3)=13
QUIT
if $PIECE(X3,U,3)=14
QUIT
+13 ; only VBECS parent orders, to get to veiled child orders
+14 IF $ORDER(^OR(100,ORDER,2,0))
if $PIECE(X0,U,14)'=VBECS
QUIT
Begin DoDot:2
+15 SET ORKID=0
FOR
SET ORKID=$ORDER(^OR(100,ORDER,2,ORKID))
if ORKID<1
QUIT
Begin DoDot:3
+16 ;VBECS child orders
if $PIECE($GET(^OR(100,ORKID,0)),U,14)'=VBECS
QUIT
+17 SET VPRN=VPRN+1
SET DLIST(VPRN)=ORKID
End DoDot:3
End DoDot:2
QUIT
+18 IF $PIECE(X3,U,9)
IF $PIECE($GET(^OR(100,+$PIECE(X3,U,9),0)),U,14)=VBECS
QUIT
+19 SET VPRN=VPRN+1
SET DLIST(VPRN)=ORDER
End DoDot:1
if VPRN'<DMAX
QUIT
+20 KILL ^TMP("ORR",$JOB)
+21 QUIT
+22 ;
ONE(ID) ; -- ID processing for Lab order returns: [not in use yet]
+1 ; ORPK = Lab order/data string
+2 ; ORDAD = parent order#
+3 ; VPRCDT = Lab collection (start) date.time
+4 ; VPRVBEC = 1 or 0, if VBECS order
+5 ; ORLAB = associated Lab child order#, if VBECS
+6 ;
+7 SET ID=+$GET(ID)
if ID<1
QUIT
SET ORLAB=""
+8 SET VPRCDT=$PIECE($GET(^OR(100,ID,0)),U,8)
SET ORDAD=$PIECE($GET(^(3)),U,9)
SET ORPK=$GET(^(4))
+9 ;get lab child#
SET VPRVBEC=$$VB(ID)
IF VPRVBEC
Begin DoDot:1
+10 SET ORLAB=$$VALUE^ORX8(ID,"LAB")
IF 'ORLAB
SET DDEOUT=1
QUIT
+11 SET VPRCDT=$PIECE($GET(^OR(100,ORLAB,0)),U,8)
SET ORPK=$GET(^(4))
End DoDot:1
QUIT
+12 QUIT
+13 ;
VB(ORIFN) ; -- return 1 or 0, if order is for Blood Bank
+1 NEW X,Y,DG
SET Y=0
+2 SET X=$PIECE($GET(^OR(100,+$GET(ORIFN),0)),U,11)
SET DG=$PIECE($GET(^ORD(100.98,+X,0)),U,3)
+3 IF DG?1"VB".E
SET Y=1
+4 QUIT Y
+5 ;
DG(DG) ; -- convert DG to section, if needed
+1 ; Returns LRSUB = DG abbreviation
+2 ;get LR section
NEW X,Y
SET X=""
SET Y=0
Begin DoDot:1
+3 SET X=$PIECE($GET(ORPK),";",4)
if $LENGTH(X)
QUIT
+4 SET X=$PIECE($GET(^ORD(101.43,+$GET(ORIT),"LR")),U,6)
if $LENGTH(X)
QUIT
+5 IF $GET(VPRVBEC)
SET X="VBEC"
End DoDot:1
+6 IF X'=""
SET Y=$ORDER(^ORD(100.98,"B",X,0))
if Y
SET DG=Y
+7 SET LRSUB=$PIECE($GET(^ORD(100.98,+$GET(DG),0)),U,3)
+8 QUIT
+9 ;
LRDFN(ORIFN) ; -- set up LRDFN for Lab Order
+1 IF '$GET(DFN)
IF $GET(ORIFN)
SET DFN=+$$GET1^DIQ(100,+ORIFN_",",.02,"I")
+2 SET LRDFN=$SELECT($GET(DFN):$$LRDFN^LRPXAPIU(DFN),1:0)
+3 QUIT
+4 ;
RSLT ; -- get Entity for LabOrder Result
+1 ; Returns VALUE, ENTITY, DATA
+2 NEW SUB,IDT
SET SUB=$SELECT($GET(VPRVBEC):"BB",1:$GET(LRSUB))
+3 ;for now
IF SUB="BB"
SET DDEOUT=1
QUIT
+4 SET IDT=$PIECE($GET(ORPK),";",5)
if 'IDT
SET IDT=9999999-$GET(VPRCDT)
+5 SET VALUE=IDT_","_+$GET(LRDFN)
SET ENTITY="VPR LR"_SUB_" RESULT"
+6 SET ENTITY=+$ORDER(^DDE("B",ENTITY,0))
IF ENTITY<1
SET DDEOUT=1
QUIT
+7 ;#60 ien ordered
SET DATA=+$PIECE($GET(ORIT),U,3)
+8 QUIT
+9 ;
CH(TEST) ; -- builds DLIST(#) of result nodes for TEST
+1 ; called from ResultItems in VPR LRCH RESULT, expects DIEN
+2 ;only return final results
if '$PIECE($GET(LR0),U,3)
QUIT
+3 NEW T,X
SET TEST=+$GET(TEST)
+4 DO EXPAND^LR7OU1(TEST,.DLIST)
+5 SET T=0
FOR
SET T=$ORDER(DLIST(T))
if T<1
QUIT
Begin DoDot:1
+6 ;not displayable
SET X=$PIECE($GET(^LAB(60,T,0)),U,3)
IF X'="O"
IF X'="B"
QUIT
+7 ; DLIST(60 ien) = CH data node#,LRIDT,LRDFN
+8 SET DLIST(T)=$$LRDN^LRPXAPIU(T)_","_DIEN
End DoDot:1
+9 QUIT
+10 ;
VALRNG(LOW,HIGH) ; -- Validate that range values will be accepted in SDA format for <ResultNormalRange> post REFRNG execution
+1 ;LOW - Range low value
+2 ;HIGH - range high value
+3 ;RESULT - Ture/False value, will pass or fail SDA <ResultNormalRnage> format
+4 NEW RESULT
+5 SET RESULT=1
+6 SET LOW=$GET(LOW)
SET HIGH=$GET(HIGH)
+7 ;Strip any surrounding quotes
+8 IF LOW?1"""".E1""""
SET LOW=$EXTRACT(LOW,2,$LENGTH(LOW)-1)
+9 IF HIGH?1"""".E1""""
SET HIGH=$EXTRACT(HIGH,2,$LENGTH(HIGH)-1)
+10 ;If both parameters are defined, we have a ##-## range and the first character of LOW and HIGH must be numeric.
+11 IF LOW'=""
IF (HIGH'="")
Begin DoDot:1
+12 IF $EXTRACT(LOW)'?1N
IF ($EXTRACT(LOW,1,2)'?1"."1N)
SET RESULT=0
+13 IF $EXTRACT(HIGH)'?1N
IF ($EXTRACT(HIGH,1,2)'?1"."1N)
SET RESULT=0
End DoDot:1
+14 QUIT RESULT
+15 ;
REFRNG(RLV,RHV) ; -- format low-high ref range string
+1 ;RLV - Range low value
+2 ;RHV - Range high value
+3 ;Based on supported EN^LRLRRVF
+4 SET RLV=$GET(RLV)
SET RHV=$GET(RHV)
+5 IF RLV=""
IF RHV=""
QUIT RLV
+6 ;Strip any surrounding quotes
+7 IF RLV?1"""".E1""""
SET RLV=$EXTRACT(RLV,2,$LENGTH(RLV)-1)
+8 IF RHV?1"""".E1""""
SET RHV=$EXTRACT(RHV,2,$LENGTH(RHV)-1)
+9 ;If only the low is defined
+10 IF RLV'=""
IF RHV=""
Begin DoDot:1
+11 IF RLV=0
SET RLV=">"_RLV
QUIT
+12 ;ok
IF ($EXTRACT(RLV)="<")!($EXTRACT(RLV)=">")
QUIT
+13 ;numeric
IF (RLV?.N.".".N)
SET RLV=">"_RLV
QUIT
+14 ;else return RLV as is (non-numeric)
End DoDot:1
QUIT RLV
+15 ;If only the high is defined
+16 IF RLV=""
IF RHV'=""
Begin DoDot:1
+17 IF RHV=0
SET RHV="<"_RHV
QUIT
+18 ;ok
IF ($EXTRACT(RHV)="<")!($EXTRACT(RHV)=">")
QUIT
+19 ;numeric
IF (RHV?.N.".".N)
SET RHV="<"_RHV
QUIT
+20 SET RHV="-"_RHV
End DoDot:1
QUIT RHV
+21 ;If both are defined
+22 QUIT RLV_"-"_RHV
+23 ;
MI1(D0,D1) ; -- return MI approval node
+1 NEW GBL,N,X,Y
+2 SET D0=+$GET(D0)
SET D1=+$GET(D1)
SET GBL=$NAME(^LR(D0,"MI",D1))
SET Y=""
+3 FOR N=1,5,8,11,16
SET X=$GET(@GBL@(N))
IF X
IF $PIECE(X,U,2)="F"
Begin DoDot:1
+4 SET Y=$PIECE(X,U,1,2)_U_$SELECT(N=11:$PIECE(X,U,5),1:$PIECE(X,U,3))
End DoDot:1
QUIT
+5 QUIT Y
+6 ;
APRPTS ; -- Anatomic Pathology reports query [from DDEGET]
+1 ; Expects DFN, DSTRT,DSTOP, DMAX, LRDFN
+2 ; Return DLIST(#) = IDT,LRDFN~SUB
+3 NEW SUB,IDT,VPRN,CTR
SET VPRN=0
+4 DO RR^LR7OR1(DFN,,DSTRT,DSTOP,"AP")
+5 SET SUB=""
FOR
SET SUB=$ORDER(^TMP("LRRR",$JOB,DFN,SUB))
if SUB=""
QUIT
Begin DoDot:1
+6 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
IF $ORDER(^(IDT,0))
Begin DoDot:2
+7 ;report in TIU
if $ORDER(^LR(LRDFN,SUB,IDT,.05,0))
QUIT
+8 ;not final results
if '$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,11)
QUIT
+9 SET VPRN=VPRN+1
SET DLIST(VPRN)=IDT_","_LRDFN_"~"_SUB
End DoDot:2
if VPRN'<DMAX
QUIT
End DoDot:1
+10 KILL ^TMP("LRRR",$JOB,DFN)
+11 QUIT
+12 ;
MIRPTS ; -- Microbiology reports query [from DDEGET]
+1 ; Expects DFN, DSTRT,DSTOP, DMAX, LRDFN
+2 ; Return DLIST(#) = IDT,LRDFN~SUB
+3 NEW IDT,VPRN,CTR
SET VPRN=0
+4 DO RR^LR7OR1(DFN,,DSTRT,DSTOP,"MI")
+5 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,"MI",IDT))
if IDT<1
QUIT
IF $ORDER(^(IDT,0))
Begin DoDot:1
+6 ;Q:'$P($G(^LR(LRDFN,"MI",IDT,0)),U,3) ;not final results
+7 ;not final results
if '$$MI1^VPRSDAB(LRDFN,IDT)
QUIT
+8 SET VPRN=VPRN+1
SET DLIST(VPRN)=IDT_","_LRDFN_"~MI"
End DoDot:1
if VPRN'<DMAX
QUIT
+9 KILL ^TMP("LRRR",$JOB,DFN)
+10 QUIT
+11 ;
AP1(ID) ; -- parse ID='IDT,LRDFN~SUB' for AP,MI report
+1 ; Returns DIFN, LRSUB, updated ID, LR0=^LR(LRDFN,SUB,IDT,0)
+2 ; and LR1=^LR(LRDFN,"MI",IDT,#) report approval if MI
+3 SET ID=$GET(ID)
SET LRSUB=$PIECE(ID,"~",2)
SET ID=$PIECE(ID,"~")
+4 ;sub-file#
IF LRSUB
Begin DoDot:1
+5 SET DIFN=LRSUB
SET LRSUB=$SELECT(DIFN=63.05:"MI",DIFN=63.09:"CY",DIFN=63.02:"EM",DIFN=63.08:"SP",1:"AP")
End DoDot:1
+6 IF '$TEST
SET DIFN=$SELECT(LRSUB="MI":63.05,LRSUB="CY":63.09,LRSUB="EM":63.02,LRSUB="SP":63.08,1:0)
+7 IF DIFN<1
SET DDEOUT=1
QUIT
+8 if '$GET(LRDFN)
SET LRDFN=+$PIECE(ID,",",2)
+9 SET LR0=$GET(^LR(LRDFN,LRSUB,+ID,0))
+10 IF LRSUB="MI"
SET LR1=$$MI1(LRDFN,+ID)
+11 QUIT
+12 ;
RR ; -- returns addl reports for order in DLIST(#) = IDT;SUB or IEN;TIU
+1 ; Expects DFN, ORPK, LRDFN
+2 NEW SUB,IDT,X,CNT
+3 if $GET(DFN)<1
QUIT
if $PIECE($GET(ORPK),";",4)=""
QUIT
+4 DO RR^LR7OR1(DFN,ORPK)
+5 SET SUB=$PIECE(ORPK,";",4)
SET CNT=0
+6 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
Begin DoDot:1
+7 ;returned in Result.DocumentNumber
if $PIECE(ORPK,";",5)=IDT
QUIT
+8 IF SUB="MI"
if '$$MI1(LRDFN,IDT)
QUIT
SET X=IDT_";MI"
+9 IF SUB'="MI"
if '$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,11)
QUIT
SET X=$$LRTIU(SUB,IDT)
+10 SET CNT=CNT+1
SET DLIST(CNT)=X
End DoDot:1
+11 QUIT
+12 ;
LRTIU(IDT,SUB) ; -- return TIU ien of lab report
+1 NEW I,IEN,X,Y
+2 SET IDT=$GET(IDT)
SET SUB=$GET(SUB)
SET Y=IDT_";"_SUB
+3 SET I=0
FOR
SET I=$ORDER(^LR(LRDFN,SUB,IDT,.05,I))
if I<1
QUIT
SET IEN=+$PIECE($GET(^(I,0)),U,2)
SET X=+$$GET1^DIQ(8925,IEN,.05,"I")
IF (X=7)!(X=8)
SET Y=IEN_";TIU"
QUIT
+4 QUIT Y
+5 ;
RPT(SUB,IDT) ; -- return report text in WP(), expects DFN
+1 NEW I,DATE,NAME,VPRS,VPRY,X,LRAU
+2 ;protect
NEW LRSUB,TAG,FILE,FIELD,IEN
+3 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+4 SET DATE=9999999-+$GET(IDT)
SET NAME=$SELECT(SUB="EM":"EM",1:$$NAME^VPRDLRA(SUB))
SET VPRS(NAME)=""
+5 DO EN^LR7OSUM(.VPRY,DFN,DATE,DATE,,,.VPRS)
+6 ;LRH=header
SET I=+$GET(^TMP("LRH",$JOB,NAME))
+7 FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
if I<1
QUIT
SET X=$GET(^(I,0))
if X?1."="
QUIT
SET WP(I)=X
+8 KILL ^TMP("LRC",$JOB),^TMP("LRH",$JOB),^TMP("LRT",$JOB)
+9 QUIT
