ORRCACK ;SLC/MKB - Result Acknowledgement file utilities ; 25 Jul 2003 9:31 AM
;;1.0;CARE MANAGEMENT;;Jul 15, 2003;Build 8
;
; ID = "ORR:"_order# everywhere below
;
PARAM(PROV) ; -- Return ORRC ACTIVATION DATE parameter for PROV
N SERV,Y S PROV=+$G(PROV),SERV=+$G(^VA(200,PROV,5))
S Y=$$GET^XPAR("ALL^USR.`"_PROV_"^SRV.`"_SERV,"ORRC ACTIVATION DATE")
Q Y
;
ADD(ORDER,PROV,ACK) ; -- Create new entry in file #102.4 when results are posted
; [called from HL7 messages: ORMLR, ORMRA, ORMGMRC]
Q:'$G(ORDER) N X,Y,DIC,DO,STOP
I '$G(ACK),+$G(PROV) D Q:$G(STOP)
. I $D(^ORA(102.4,"ACK",PROV,+$G(ORDER))) S STOP=1 Q ;exists
. N ACTDT S ACTDT=$$PARAM(PROV)
. I (ACTDT<1)!(ACTDT>DT) S STOP=1 Q ;not [yet] active
S DIC="^ORA(102.4,",DIC(0)="" S:$G(PROV) DIC("DR")="2////"_+PROV
S X=+ORDER D FILE^DICN
Q
;
ACK(ORY,ORUSR,ORDER) ; -- Acknowledge results of ORDERs by ORUSR
; where ORDER(#) = ID ^ 1 or 0, if acknowledged
; Returns ORY(#) = ID ^ 1 or 0, if successful
; RPC = ORRC RESULTS ACKNOWLEDGE
Q:'$G(ORUSR) N X,Y,DA,DR,DIE,ORI,ORIFN,ORACK,ORXQ
S DIE="^ORA(102.4,",ORUSR=+$G(ORUSR)
S ORI="" F S ORI=$O(ORDER(ORI)) Q:ORI="" D
. S X=ORDER(ORI),ORIFN=$P(X,U),ORACK=+$P(X,U,2)
. S ORY(ORI)=ORIFN_"^0",ORIFN=+$P(ORIFN,":",2) Q:ORIFN<1
. I '$D(^ORA(102.4,"ACK",+ORUSR,+ORIFN)) D ADD(ORIFN,ORUSR,1)
. S DA=+$O(^ORA(102.4,"ACK",+ORUSR,+ORIFN,0)) Q:DA<1
. S DR="3///"_$S(ORACK:"NOW",1:"@") D ^DIE
. S $P(ORY(ORI),U,2)=1,ORXQ(+ORIFN)=""
D:$D(ORXQ) RSLT^ORRCXQ(.ORXQ,ORUSR)
Q
;
DEL(DA) ; -- Delete old acknowledgment stub
N DIK S DIK="^ORA(102.4,"
I $G(DA),'$P($G(^ORA(102.4,DA,0)),U,3) D ^DIK
Q
;
PATS(ORY,ORUSR) ; -- Return list of patients for whom ORUSR has unack'd results
; in @ORY@(PAT) = #orders ^ 1 if any are abnormal
; @ORY@(PAT,ID) = * if abnormal, else null
; [from ORRCDPT]
N ORIFN,PAT,ABN,X,CNT,ACTDT,RDT,ACK
S ORUSR=+$G(ORUSR),ACTDT=$$PARAM(ORUSR)
S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY,^TMP($J,"ORSLT")
S ORIFN=0 F S ORIFN=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN)) Q:ORIFN<1 D
. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
. S PAT=+$P($G(^OR(100,ORIFN,0)),U,2),RDT=+$G(^(7)),ABN=$P($G(^(7)),U,2)
. I $D(^TMP($J,"ORRCLST")),'$D(^TMP($J,"ORRCY",PAT)) Q ;pt not on list
. I 'ACTDT!(RDT<ACTDT) S ACK=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN,0)) D DEL(ACK) Q ;remove old stub
. S X=$G(ORY(PAT)),CNT=+X
. S CNT=CNT+1,@ORY@(PAT)=CNT_$S(ABN!$P(X,U,2):"^1",1:"")
. S @ORY@(PAT,"ORR:"_ORIFN)=$S(ABN:"*",1:"")
. D ORSLT ;temp xref for PATS^ORRCEVT
Q
;
ORSLT ; -- Add ORIFN to ^TMP($J,"ORSLT",PAT,pkgid) for use by Events
N OR0,OR4,NMSP,X
S OR0=$G(^OR(100,+ORIFN,0)),OR4=$G(^(4)),X=""
S NMSP=$$NMSP^ORCD($P(OR0,U,14)) I NMSP="RA" D Q
. N IDX S IDX="^RADPT(""AO"",+OR4,PAT)"
. F S IDX=$Q(@IDX) Q:$P(IDX,",",2)'=+OR4 Q:$P(IDX,",",3)'=PAT S X=$P(IDX,",",4)_"~"_$P(IDX,",",5),^TMP($J,"ORSLT",PAT,X)=+ORIFN
I NMSP="LR" S X=+ORIFN_"@OR"
I NMSP="GMRC" S X=+OR4
S:$L(X) ^TMP($J,"ORSLT",PAT,X)=+ORIFN
Q
;
IDS(ORY,ORPAT,ORUSR,SDATE,EDATE) ; -- Return new results for ORPAT
; between ORBEG & OREND that ORUSR has not acknowledged
; in @ORY@(ORPAT) = #orders ^ 1 if any are abnormal
; @ORY@(ORPAT,ID) = * if abnormal, else null
; [from ORRCDPT1]
N CNT,ORIFN,ORDT,ABN,X
S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT)_";DPT(",CNT=0
S SDATE=$G(SDATE),EDATE=$G(EDATE) D DT1 ;defaults ??
S ORDT=SDATE F S ORDT=$O(^OR(100,"ARS",ORPAT,ORDT)) Q:ORDT<1 Q:ORDT>EDATE D
. S ORIFN=0 F S ORIFN=+$O(^OR(100,"ARS",ORPAT,ORDT,ORIFN)) Q:ORIFN<1 D
.. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
.. Q:$$ACKD(ORIFN,ORUSR) S CNT=CNT+1,X=$P($G(^OR(100,ORIFN,7)),U,2)
.. S @ORY@(+ORPAT,"ORR:"_ORIFN)=$S(X:"*",1:"") S:X ABN=1
S:CNT @ORY@(+ORPAT)=CNT_U_$G(ABN)
Q
;
LIST(ORY,ORUSR,ORPAT,ORSLT) ; -- Return orders by ORUSR for ORPAT with new results
; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
; = Cmnt=result comment
; or Text=line of report text
; RPC = ORRC RESULTS BY PATIENT
N ORN,ORIFN,ORTX,ORDT
S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT),ORN=0
S ORIFN=0 F S ORIFN=+$O(^ORA(102.4,"ACK",ORUSR,ORIFN)) Q:ORIFN<1 I +$P($G(^OR(100,ORIFN,0)),U,2)=ORPAT D
. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
. D TEXT^ORQ12(.ORTX,ORIFN) S ORDT=+$G(^OR(100,ORIFN,7))
. S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
. I $G(ORSLT) D ORD ;add results data to ORY(#)
;S ORY(0)=CNT
Q
;
LISTD(ORY,ORPAT,ORUSR,ORBEG,OREND,ORSLT) ; -- Return new results for ORPAT
; between ORBEG & OREND that ORUSR has not acknowledged
; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
; = Cmnt=result comment
; or Text=line of report text
; RPC = ORRC RESULTS BY DATE
N ORN,ORIFN,ORTX,ORDT,SDATE,EDATE
S ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
S ORUSR=+$G(ORUSR),ORPAT=+$G(ORPAT)_";DPT(",ORN=0 D DATES
S ORDT=SDATE F S ORDT=$O(^OR(100,"ARS",ORPAT,ORDT)) Q:ORDT<1 Q:ORDT>EDATE D
. S ORIFN=0 F S ORIFN=+$O(^OR(100,"ARS",ORPAT,ORDT,ORIFN)) Q:ORIFN<1 D
.. Q:+$P($G(^OR(100,ORIFN,3)),U,3)=9 ;partial results
.. Q:$$ACKD(ORIFN,ORUSR) D TEXT^ORQ12(.ORTX,ORIFN)
.. S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
.. I $G(ORSLT) D ORD ;add results data to ORY(#)
Q
;
DATES ; -- Return SDATE and EDATE from ORBEG and OREND
; [Inverted for rev-chron search]
S SDATE=$$HL7TFM^XLFDT($G(ORBEG)),EDATE=$$HL7TFM^XLFDT($G(OREND))
DT1 I EDATE S EDATE=$S($L(EDATE,".")=2:EDATE+.0001,1:EDATE+1)
I SDATE S SDATE=$S($L(SDATE,".")=2:SDATE-.0001,1:SDATE)
S SDATE=9999999-$S(SDATE:SDATE,1:0),EDATE=9999999-$S(EDATE:EDATE,1:9999998)
S X=EDATE,EDATE=SDATE,SDATE=X
Q
;
ACKD(ORDER,USER) ; -- Returns 1 or 0, if USER has acknowledged ORDER
N Y S Y=0
S IFN=0 F S IFN=$O(^ORA(102.4,"B",+$G(ORDER),IFN)) Q:IFN<1 D Q:Y
. S X=$G(^ORA(102.4,IFN,0)) I $P(X,U,3),$P(X,U,2)=+$G(USER) S Y=1 Q
Q Y
;
RESULT(ORY,ORDER) ; -- Return results of ORDERs
; where ORDER(#) = ID
; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and
; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
; = Cmnt=result comment
; or Text=line of report text
; RPC = ORRC RESULTS BY ID
N ORN,ORI,ORIFN,ORDT,ORTX
S ORN=0,ORY=$NA(^TMP($J,"ORRCRSLT")) K @ORY
S ORI="" F S ORI=$O(ORDER(ORI)) Q:ORI="" S ORIFN=ORDER(ORI) D
. S ORIFN=+$P(ORIFN,":",2),ORDT=+$G(^OR(100,ORIFN,7))
. D TEXT^ORQ12(.ORTX,ORIFN)
. S ORN=ORN+1,@ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
. D ORD
Q
;
ORD ; -- Add results for ORIFN to @ORY@(ORN)
N PKG Q:'+$G(ORIFN)
S PKG=+$P($G(^OR(100,ORIFN,0)),U,14),PKG=$$NMSP^ORCD(PKG)
I "^LR^RA^GMRC^"'[(U_PKG_U)!'ORIFN S ORY(1)="Text=No results available." Q ;DT??
D @PKG
Q
LR ; -- Lab results
N ORVP,LRID,LRTST,LRSUB,I,X K ^TMP("LRRR",$J)
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),LRID=$G(^(4))
I '$L(LRID) S ORN=ORN+1,@ORY@(ORN)="Text=No results available." Q
S X=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE"),LRTST=+$P($G(^ORD(101.43,+X,0)),U,2)
I +LRID D RR^LR7OR1(+ORVP,LRID,,,,LRTST) I '$D(^TMP("LRRR",$J,+ORVP)) S $P(LRID,";",1,3)=";;" ;Order possibly purged, reset to lookup on file 63
I '+LRID,$P(LRID,";",5) D RR^LR7OR1(+ORVP,,9999999-$P(LRID,";",5),9999999-$P(LRID,";",5),$P(LRID,";",4),LRTST)
I '$D(^TMP("LRRR",$J,+ORVP)) S ORN=ORN+1,@ORY@(ORN)="Text=No results available." Q
S LRSUB=$O(^TMP("LRRR",$J,+ORVP,"")) Q:LRSUB=""
S LRDT=$O(^TMP("LRRR",$J,+ORVP,LRSUB,0)) I LRDT S LRDT=9999999-LRDT,$P(@ORY@(ORN),U,3)=$$FMTHL7^XLFDT(LRDT) ;return Coll Dt instead of Results Dt
I LRSUB="CH" D K ^TMP("LRRR",$J) Q
. N TEST,LRDT,LRN,LRI M TEST=^TMP("LRRR",$J,+ORVP,"CH")
. S LRDT=0 F S LRDT=$O(TEST(LRDT)) Q:LRDT<1 S LRN=0 F S LRN=$O(TEST(LRDT,LRN)) Q:LRN="" D
.. I LRN S I=$G(TEST(LRDT,LRN)),X=$P($G(^LAB(60,+I,0)),U)_U_$P(I,U,2)_U_$P(I,U,4,5)_U_$P(I,U,3) S ORN=ORN+1,@ORY@(ORN)="Data="_X
.. I LRN="N" S LRI=0 F S LRI=$O(TEST(LRDT,LRN,LRI)) Q:LRI<1 S ORN=ORN+1,@ORY@(ORN)="Cmnt="_$G(TEST(LRDT,LRN,LRI))
K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP):LRSUB="BB",EN^LR7OSMZ0(+ORVP):LRSUB="MI"
S I=0 F S I=+$O(^TMP("LRC",$J,I)) Q:I<1 S X=$G(^(I,0)),ORN=ORN+1,@ORY@(ORN)="Text="_X
K ^TMP("LRC",$J),^TMP("LRRR",$J)
Q
RA ; -- Radiology results
N ORVP,RAID,CASE,PROC,PSET,FIRST
S ORVP=$P($G(^OR(100,ORIFN,0)),U,2),RAID=+$G(^(4)) D EN30^RAO7PC3(RAID)
S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")),FIRST=1
I 'PSET S CASE=0 F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D
. S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D XRPT
I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D XRPT
K ^TMP($J,"RAE3",+ORVP)
Q
XRPT ; -- body of report for CASE, PROC
N ORD,X,I
I 'FIRST S ORN=ORN+1,@ORY@(ORN)="Text="_$$REPEAT^XLFSTR(" * ",24)
S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S ORN=ORN+1,@ORY@(ORN)="Text=Proc Ord: "_ORD
S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),ORN=ORN+1,@ORY@(ORN)="Text="_X ;Skip pt ID on line 1
S FIRST=0
Q
GMRC ; -- Consult results
N GMRCID,I,X,SUB S GMRCID=+$G(^OR(100,ORIFN,4)),SUB="RT" N ORIFN ;protect
I '$D(^GMR(123,GMRCID,50,"B")),'$D(^GMR(123,GMRCID,51,"B")) S SUB="DT"
D RT^GMRCGUIA(GMRCID,"^TMP(""GMRCR"",$J,""RT"")"):SUB="RT",DT^GMRCSLM2(GMRCID):SUB="DT"
S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),ORN=ORN+1,@ORY@(ORN)="Text="_X
K ^TMP("GMRCR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORRCACK 9797 printed Apr 09, 2024@20:46:21 Page 2
ORRCACK ;SLC/MKB - Result Acknowledgement file utilities ; 25 Jul 2003 9:31 AM
+1 ;;1.0;CARE MANAGEMENT;;Jul 15, 2003;Build 8
+2 ;
+3 ; ID = "ORR:"_order# everywhere below
+4 ;
PARAM(PROV) ; -- Return ORRC ACTIVATION DATE parameter for PROV
+1 NEW SERV,Y
SET PROV=+$GET(PROV)
SET SERV=+$GET(^VA(200,PROV,5))
+2 SET Y=$$GET^XPAR("ALL^USR.`"_PROV_"^SRV.`"_SERV,"ORRC ACTIVATION DATE")
+3 QUIT Y
+4 ;
ADD(ORDER,PROV,ACK) ; -- Create new entry in file #102.4 when results are posted
+1 ; [called from HL7 messages: ORMLR, ORMRA, ORMGMRC]
+2 if '$GET(ORDER)
QUIT
NEW X,Y,DIC,DO,STOP
+3 IF '$GET(ACK)
IF +$GET(PROV)
Begin DoDot:1
+4 ;exists
IF $DATA(^ORA(102.4,"ACK",PROV,+$GET(ORDER)))
SET STOP=1
QUIT
+5 NEW ACTDT
SET ACTDT=$$PARAM(PROV)
+6 ;not [yet] active
IF (ACTDT<1)!(ACTDT>DT)
SET STOP=1
QUIT
End DoDot:1
if $GET(STOP)
QUIT
+7 SET DIC="^ORA(102.4,"
SET DIC(0)=""
if $GET(PROV)
SET DIC("DR")="2////"_+PROV
+8 SET X=+ORDER
DO FILE^DICN
+9 QUIT
+10 ;
ACK(ORY,ORUSR,ORDER) ; -- Acknowledge results of ORDERs by ORUSR
+1 ; where ORDER(#) = ID ^ 1 or 0, if acknowledged
+2 ; Returns ORY(#) = ID ^ 1 or 0, if successful
+3 ; RPC = ORRC RESULTS ACKNOWLEDGE
+4 if '$GET(ORUSR)
QUIT
NEW X,Y,DA,DR,DIE,ORI,ORIFN,ORACK,ORXQ
+5 SET DIE="^ORA(102.4,"
SET ORUSR=+$GET(ORUSR)
+6 SET ORI=""
FOR
SET ORI=$ORDER(ORDER(ORI))
if ORI=""
QUIT
Begin DoDot:1
+7 SET X=ORDER(ORI)
SET ORIFN=$PIECE(X,U)
SET ORACK=+$PIECE(X,U,2)
+8 SET ORY(ORI)=ORIFN_"^0"
SET ORIFN=+$PIECE(ORIFN,":",2)
if ORIFN<1
QUIT
+9 IF '$DATA(^ORA(102.4,"ACK",+ORUSR,+ORIFN))
DO ADD(ORIFN,ORUSR,1)
+10 SET DA=+$ORDER(^ORA(102.4,"ACK",+ORUSR,+ORIFN,0))
if DA<1
QUIT
+11 SET DR="3///"_$SELECT(ORACK:"NOW",1:"@")
DO ^DIE
+12 SET $PIECE(ORY(ORI),U,2)=1
SET ORXQ(+ORIFN)=""
End DoDot:1
+13 if $DATA(ORXQ)
DO RSLT^ORRCXQ(.ORXQ,ORUSR)
+14 QUIT
+15 ;
DEL(DA) ; -- Delete old acknowledgment stub
+1 NEW DIK
SET DIK="^ORA(102.4,"
+2 IF $GET(DA)
IF '$PIECE($GET(^ORA(102.4,DA,0)),U,3)
DO ^DIK
+3 QUIT
+4 ;
PATS(ORY,ORUSR) ; -- Return list of patients for whom ORUSR has unack'd results
+1 ; in @ORY@(PAT) = #orders ^ 1 if any are abnormal
+2 ; @ORY@(PAT,ID) = * if abnormal, else null
+3 ; [from ORRCDPT]
+4 NEW ORIFN,PAT,ABN,X,CNT,ACTDT,RDT,ACK
+5 SET ORUSR=+$GET(ORUSR)
SET ACTDT=$$PARAM(ORUSR)
+6 SET ORY=$NAME(^TMP($JOB,"ORRCRSLT"))
KILL @ORY,^TMP($JOB,"ORSLT")
+7 SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^ORA(102.4,"ACK",ORUSR,ORIFN))
if ORIFN<1
QUIT
Begin DoDot:1
+8 ;partial results
if +$PIECE($GET(^OR(100,ORIFN,3)),U,3)=9
QUIT
+9 SET PAT=+$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET RDT=+$GET(^(7))
SET ABN=$PIECE($GET(^(7)),U,2)
+10 ;pt not on list
IF $DATA(^TMP($JOB,"ORRCLST"))
IF '$DATA(^TMP($JOB,"ORRCY",PAT))
QUIT
+11 ;remove old stub
IF 'ACTDT!(RDT<ACTDT)
SET ACK=+$ORDER(^ORA(102.4,"ACK",ORUSR,ORIFN,0))
DO DEL(ACK)
QUIT
+12 SET X=$GET(ORY(PAT))
SET CNT=+X
+13 SET CNT=CNT+1
SET @ORY@(PAT)=CNT_$SELECT(ABN!$PIECE(X,U,2):"^1",1:"")
+14 SET @ORY@(PAT,"ORR:"_ORIFN)=$SELECT(ABN:"*",1:"")
+15 ;temp xref for PATS^ORRCEVT
DO ORSLT
End DoDot:1
+16 QUIT
+17 ;
ORSLT ; -- Add ORIFN to ^TMP($J,"ORSLT",PAT,pkgid) for use by Events
+1 NEW OR0,OR4,NMSP,X
+2 SET OR0=$GET(^OR(100,+ORIFN,0))
SET OR4=$GET(^(4))
SET X=""
+3 SET NMSP=$$NMSP^ORCD($PIECE(OR0,U,14))
IF NMSP="RA"
Begin DoDot:1
+4 NEW IDX
SET IDX="^RADPT(""AO"",+OR4,PAT)"
+5 FOR
SET IDX=$QUERY(@IDX)
if $PIECE(IDX,",",2)'=+OR4
QUIT
if $PIECE(IDX,",",3)'=PAT
QUIT
SET X=$PIECE(IDX,",",4)_"~"_$PIECE(IDX,",",5)
SET ^TMP($JOB,"ORSLT",PAT,X)=+ORIFN
End DoDot:1
QUIT
+6 IF NMSP="LR"
SET X=+ORIFN_"@OR"
+7 IF NMSP="GMRC"
SET X=+OR4
+8 if $LENGTH(X)
SET ^TMP($JOB,"ORSLT",PAT,X)=+ORIFN
+9 QUIT
+10 ;
IDS(ORY,ORPAT,ORUSR,SDATE,EDATE) ; -- Return new results for ORPAT
+1 ; between ORBEG & OREND that ORUSR has not acknowledged
+2 ; in @ORY@(ORPAT) = #orders ^ 1 if any are abnormal
+3 ; @ORY@(ORPAT,ID) = * if abnormal, else null
+4 ; [from ORRCDPT1]
+5 NEW CNT,ORIFN,ORDT,ABN,X
+6 SET ORY=$NAME(^TMP($JOB,"ORRCRSLT"))
KILL @ORY
+7 SET ORUSR=+$GET(ORUSR)
SET ORPAT=+$GET(ORPAT)_";DPT("
SET CNT=0
+8 ;defaults ??
SET SDATE=$GET(SDATE)
SET EDATE=$GET(EDATE)
DO DT1
+9 SET ORDT=SDATE
FOR
SET ORDT=$ORDER(^OR(100,"ARS",ORPAT,ORDT))
if ORDT<1
QUIT
if ORDT>EDATE
QUIT
Begin DoDot:1
+10 SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^OR(100,"ARS",ORPAT,ORDT,ORIFN))
if ORIFN<1
QUIT
Begin DoDot:2
+11 ;partial results
if +$PIECE($GET(^OR(100,ORIFN,3)),U,3)=9
QUIT
+12 if $$ACKD(ORIFN,ORUSR)
QUIT
SET CNT=CNT+1
SET X=$PIECE($GET(^OR(100,ORIFN,7)),U,2)
+13 SET @ORY@(+ORPAT,"ORR:"_ORIFN)=$SELECT(X:"*",1:"")
if X
SET ABN=1
End DoDot:2
End DoDot:1
+14 if CNT
SET @ORY@(+ORPAT)=CNT_U_$GET(ABN)
+15 QUIT
+16 ;
LIST(ORY,ORUSR,ORPAT,ORSLT) ; -- Return orders by ORUSR for ORPAT with new results
+1 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
+2 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
+3 ; = Cmnt=result comment
+4 ; or Text=line of report text
+5 ; RPC = ORRC RESULTS BY PATIENT
+6 NEW ORN,ORIFN,ORTX,ORDT
+7 SET ORY=$NAME(^TMP($JOB,"ORRCRSLT"))
KILL @ORY
+8 SET ORUSR=+$GET(ORUSR)
SET ORPAT=+$GET(ORPAT)
SET ORN=0
+9 SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^ORA(102.4,"ACK",ORUSR,ORIFN))
if ORIFN<1
QUIT
IF +$PIECE($GET(^OR(100,ORIFN,0)),U,2)=ORPAT
Begin DoDot:1
+10 ;partial results
if +$PIECE($GET(^OR(100,ORIFN,3)),U,3)=9
QUIT
+11 DO TEXT^ORQ12(.ORTX,ORIFN)
SET ORDT=+$GET(^OR(100,ORIFN,7))
+12 SET ORN=ORN+1
SET @ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
+13 ;add results data to ORY(#)
IF $GET(ORSLT)
DO ORD
End DoDot:1
+14 ;S ORY(0)=CNT
+15 QUIT
+16 ;
LISTD(ORY,ORPAT,ORUSR,ORBEG,OREND,ORSLT) ; -- Return new results for ORPAT
+1 ; between ORBEG & OREND that ORUSR has not acknowledged
+2 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and also if ORSLT
+3 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
+4 ; = Cmnt=result comment
+5 ; or Text=line of report text
+6 ; RPC = ORRC RESULTS BY DATE
+7 NEW ORN,ORIFN,ORTX,ORDT,SDATE,EDATE
+8 SET ORY=$NAME(^TMP($JOB,"ORRCRSLT"))
KILL @ORY
+9 SET ORUSR=+$GET(ORUSR)
SET ORPAT=+$GET(ORPAT)_";DPT("
SET ORN=0
DO DATES
+10 SET ORDT=SDATE
FOR
SET ORDT=$ORDER(^OR(100,"ARS",ORPAT,ORDT))
if ORDT<1
QUIT
if ORDT>EDATE
QUIT
Begin DoDot:1
+11 SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^OR(100,"ARS",ORPAT,ORDT,ORIFN))
if ORIFN<1
QUIT
Begin DoDot:2
+12 ;partial results
if +$PIECE($GET(^OR(100,ORIFN,3)),U,3)=9
QUIT
+13 if $$ACKD(ORIFN,ORUSR)
QUIT
DO TEXT^ORQ12(.ORTX,ORIFN)
+14 SET ORN=ORN+1
SET @ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
+15 ;add results data to ORY(#)
IF $GET(ORSLT)
DO ORD
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
DATES ; -- Return SDATE and EDATE from ORBEG and OREND
+1 ; [Inverted for rev-chron search]
+2 SET SDATE=$$HL7TFM^XLFDT($GET(ORBEG))
SET EDATE=$$HL7TFM^XLFDT($GET(OREND))
DT1 IF EDATE
SET EDATE=$SELECT($LENGTH(EDATE,".")=2:EDATE+.0001,1:EDATE+1)
+1 IF SDATE
SET SDATE=$SELECT($LENGTH(SDATE,".")=2:SDATE-.0001,1:SDATE)
+2 SET SDATE=9999999-$SELECT(SDATE:SDATE,1:0)
SET EDATE=9999999-$SELECT(EDATE:EDATE,1:9999998)
+3 SET X=EDATE
SET EDATE=SDATE
SET SDATE=X
+4 QUIT
+5 ;
ACKD(ORDER,USER) ; -- Returns 1 or 0, if USER has acknowledged ORDER
+1 NEW Y
SET Y=0
+2 SET IFN=0
FOR
SET IFN=$ORDER(^ORA(102.4,"B",+$GET(ORDER),IFN))
if IFN<1
QUIT
Begin DoDot:1
+3 SET X=$GET(^ORA(102.4,IFN,0))
IF $PIECE(X,U,3)
IF $PIECE(X,U,2)=+$GET(USER)
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+4 QUIT Y
+5 ;
RESULT(ORY,ORDER) ; -- Return results of ORDERs
+1 ; where ORDER(#) = ID
+2 ; in @ORY@(#) = Item=ID^Text^ResultDate in HL7 format, and
+3 ; = Data=Test^Value^Units^ReferenceRange^CriticalFlag
+4 ; = Cmnt=result comment
+5 ; or Text=line of report text
+6 ; RPC = ORRC RESULTS BY ID
+7 NEW ORN,ORI,ORIFN,ORDT,ORTX
+8 SET ORN=0
SET ORY=$NAME(^TMP($JOB,"ORRCRSLT"))
KILL @ORY
+9 SET ORI=""
FOR
SET ORI=$ORDER(ORDER(ORI))
if ORI=""
QUIT
SET ORIFN=ORDER(ORI)
Begin DoDot:1
+10 SET ORIFN=+$PIECE(ORIFN,":",2)
SET ORDT=+$GET(^OR(100,ORIFN,7))
+11 DO TEXT^ORQ12(.ORTX,ORIFN)
+12 SET ORN=ORN+1
SET @ORY@(ORN)="Item=ORR:"_ORIFN_U_ORTX(1)_U_$$FMTHL7^XLFDT(ORDT)
+13 DO ORD
End DoDot:1
+14 QUIT
+15 ;
ORD ; -- Add results for ORIFN to @ORY@(ORN)
+1 NEW PKG
if '+$GET(ORIFN)
QUIT
+2 SET PKG=+$PIECE($GET(^OR(100,ORIFN,0)),U,14)
SET PKG=$$NMSP^ORCD(PKG)
+3 ;DT??
IF "^LR^RA^GMRC^"'[(U_PKG_U)!'ORIFN
SET ORY(1)="Text=No results available."
QUIT
+4 DO @PKG
+5 QUIT
LR ; -- Lab results
+1 NEW ORVP,LRID,LRTST,LRSUB,I,X
KILL ^TMP("LRRR",$JOB)
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET LRID=$GET(^(4))
+3 IF '$LENGTH(LRID)
SET ORN=ORN+1
SET @ORY@(ORN)="Text=No results available."
QUIT
+4 SET X=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
SET LRTST=+$PIECE($GET(^ORD(101.43,+X,0)),U,2)
+5 ;Order possibly purged, reset to lookup on file 63
IF +LRID
DO RR^LR7OR1(+ORVP,LRID,,,,LRTST)
IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET $PIECE(LRID,";",1,3)=";;"
+6 IF '+LRID
IF $PIECE(LRID,";",5)
DO RR^LR7OR1(+ORVP,,9999999-$PIECE(LRID,";",5),9999999-$PIECE(LRID,";",5),$PIECE(LRID,";",4),LRTST)
+7 IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET ORN=ORN+1
SET @ORY@(ORN)="Text=No results available."
QUIT
+8 SET LRSUB=$ORDER(^TMP("LRRR",$JOB,+ORVP,""))
if LRSUB=""
QUIT
+9 ;return Coll Dt instead of Results Dt
SET LRDT=$ORDER(^TMP("LRRR",$JOB,+ORVP,LRSUB,0))
IF LRDT
SET LRDT=9999999-LRDT
SET $PIECE(@ORY@(ORN),U,3)=$$FMTHL7^XLFDT(LRDT)
+10 IF LRSUB="CH"
Begin DoDot:1
+11 NEW TEST,LRDT,LRN,LRI
MERGE TEST=^TMP("LRRR",$JOB,+ORVP,"CH")
+12 SET LRDT=0
FOR
SET LRDT=$ORDER(TEST(LRDT))
if LRDT<1
QUIT
SET LRN=0
FOR
SET LRN=$ORDER(TEST(LRDT,LRN))
if LRN=""
QUIT
Begin DoDot:2
+13 IF LRN
SET I=$GET(TEST(LRDT,LRN))
SET X=$PIECE($GET(^LAB(60,+I,0)),U)_U_$PIECE(I,U,2)_U_$PIECE(I,U,4,5)_U_$PIECE(I,U,3)
SET ORN=ORN+1
SET @ORY@(ORN)="Data="_X
+14 IF LRN="N"
SET LRI=0
FOR
SET LRI=$ORDER(TEST(LRDT,LRN,LRI))
if LRI<1
QUIT
SET ORN=ORN+1
SET @ORY@(ORN)="Cmnt="_$GET(TEST(LRDT,LRN,LRI))
End DoDot:2
End DoDot:1
KILL ^TMP("LRRR",$JOB)
QUIT
+15 KILL ^TMP("LRC",$JOB)
if LRSUB="BB"
DO EN1^LR7OSBR(+ORVP)
if LRSUB="MI"
DO EN^LR7OSMZ0(+ORVP)
+16 SET I=0
FOR
SET I=+$ORDER(^TMP("LRC",$JOB,I))
if I<1
QUIT
SET X=$GET(^(I,0))
SET ORN=ORN+1
SET @ORY@(ORN)="Text="_X
+17 KILL ^TMP("LRC",$JOB),^TMP("LRRR",$JOB)
+18 QUIT
RA ; -- Radiology results
+1 NEW ORVP,RAID,CASE,PROC,PSET,FIRST
+2 SET ORVP=$PIECE($GET(^OR(100,ORIFN,0)),U,2)
SET RAID=+$GET(^(4))
DO EN30^RAO7PC3(RAID)
+3 SET PSET=$DATA(^TMP($JOB,"RAE3",+ORVP,"PRINT_SET"))
SET FIRST=1
+4 IF 'PSET
SET CASE=0
FOR
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE))
if CASE'>0
QUIT
Begin DoDot:1
+5 SET PROC=""
FOR
SET PROC=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,PROC))
if PROC=""
QUIT
DO XRPT
End DoDot:1
+6 IF PSET
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,0))
SET PROC=$ORDER(^(CASE,""))
DO XRPT
+7 KILL ^TMP($JOB,"RAE3",+ORVP)
+8 QUIT
XRPT ; -- body of report for CASE, PROC
+1 NEW ORD,X,I
+2 IF 'FIRST
SET ORN=ORN+1
SET @ORY@(ORN)="Text="_$$REPEAT^XLFSTR(" * ",24)
+3 SET ORD=$SELECT($LENGTH($GET(^TMP($JOB,"RAE3",+ORVP,"ORD"))):^("ORD"),$LENGTH($GET(^("ORD",CASE))):^(CASE),1:"")
IF $LENGTH(ORD)
IF ORD'=PROC
SET ORN=ORN+1
SET @ORY@(ORN)="Text=Proc Ord: "_ORD
+4 ;Skip pt ID on line 1
SET I=1
FOR
SET I=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,PROC,I))
if I'>0
QUIT
SET X=^(I)
SET ORN=ORN+1
SET @ORY@(ORN)="Text="_X
+5 SET FIRST=0
+6 QUIT
GMRC ; -- Consult results
+1 ;protect
NEW GMRCID,I,X,SUB
SET GMRCID=+$GET(^OR(100,ORIFN,4))
SET SUB="RT"
NEW ORIFN
+2 IF '$DATA(^GMR(123,GMRCID,50,"B"))
IF '$DATA(^GMR(123,GMRCID,51,"B"))
SET SUB="DT"
+3 if SUB="RT"
DO RT^GMRCGUIA(GMRCID,"^TMP(""GMRCR"",$J,""RT"")")
if SUB="DT"
DO DT^GMRCSLM2(GMRCID)
+4 SET I=0
FOR
SET I=$ORDER(^TMP("GMRCR",$JOB,SUB,I))
if I'>0
QUIT
SET X=$GET(^(I,0))
SET ORN=ORN+1
SET @ORY@(ORN)="Text="_X
+5 KILL ^TMP("GMRCR",$JOB)
+6 QUIT
