ORWOR2 ;SLC/DCM - RESULT RPC FUNCTIONS ;04/28/2015 11:32
;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,350,423**;Dec 17, 1997;Build 19
ORDHIST ; -- orders - compare with ORDERS^ORCXPND1
I '$G(ORESULTS) D ORDERS^ORCXPND2 Q
; -- Result History Display (Add more packages as available)
N PKG,TAB,ORIFN
S PKG=+$P($G(^OR(100,+ID,0)),"^",14),PKG=$$NMSP^ORCD(PKG)
S TAB=$S(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
I '$L(TAB)!(ID'>0) D Q ; no display available
. N ORY,I
. D TEXT^ORQ12(.ORY,+ID,80)
. S I=0 F S I=$O(ORY(I)) Q:I'>0 D ITEM^ORCXPND(ORY(I))
. D BLANK^ORCXPND
. S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="There are no results to report in this time range."
I $O(^OR(100,+ID,2,0)) S ORIFN=+ID,ID=0 F S ID=$O(^OR(100,ORIFN,2,ID)) Q:ID<1 I $D(^OR(100,ID,0)) D @TAB
I '$O(^OR(100,+ID,2,0)) D @TAB
Q
LABS ; -- laboratory [RESULTS ONLY for ID=OE order #]
N ORIFN,X,Y,SUB,NAME,SS,IDE,IVDT,TST,CC,ORCY,IG,TCNT,ITEM,ORY,SDATE,EDATE,ITDATE,ITMDATE,NDT,STAR,LNM,LINE
K ^TMP("LRRR",$J),^TMP("LRAPI",$J)
S ORIFN=+ID,IDE=$G(^OR(100,+ID,4))
Q:'$L(IDE) ; OE# -> Lab#
S ITEM=$$VALUE^ORX8(ID,"ORDERABLE",,"I"),ITMDATE=$S($P(ID,";",2):$P($G(^OR(100,ORIFN,8,$P(ID,";",2),0)),"^",16),1:$P(^OR(100,ORIFN,0),"^",8)),ITDATE=$$FMTE^XLFDT(ITMDATE,"1M")
Q:'ITEM
S ITEM=+$P($G(^ORD(101.43,+ITEM,0)),"^",2)
S $P(IDE,";",1,3)=";;"
S SDATE=9999999-$S($P(IDE,";",5):$P(IDE,";",5),1:ITMDATE),EDATE=$$FMADD^XLFDT(DT,-1825) ;Set for previous 5 years
D RR^LR7OR1(+ORVP,,SDATE,EDATE,,ITEM,,5)
K ORCY D TEXT^ORQ12(.ORCY,ORIFN,80)
S IG=0 F S IG=$O(ORCY(IG)) Q:IG<1 S X=ORCY(IG) D ITEM^ORCXPND(X)
D BLANK^ORCXPND
I '$D(^TMP("LRRR",$J,+ORVP)) S LINE="No data available." D SETLINE(LINE,.LCNT) Q
S LINE=$S('$P(IDE,";",5):"(Results not yet available for this order)",1:"(* Results for this order)")
D SETLINE(LINE,.LCNT)
S CC=0,SS="",TCNT=0
F S SS=$O(^TMP("LRRR",$J,+ORVP,SS)) Q:SS="" S IVDT=0 F S IVDT=$O(^TMP("LRRR",$J,+ORVP,SS,IVDT)) Q:'IVDT D Q:SS="MI" Q:SS="BB"
. S NDT=1,STAR=" "
. I SS="BB" K ^TMP("LRC",$J) D EN1^LR7OSBR(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q
.. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LINE=X D SETLINE(LINE,.LCNT)
.. K ^TMP("LRC",$J)
. I SS="MI" K ^TMP("LRC",$J) D EN^LR7OSMZ0(+ORVP) Q:'$D(^TMP("LRC",$J)) D Q
.. S LINE="Previous 5 sets of related results within 5 years... " D SETLINE(LINE,.LCNT)
.. N I S I=0 F S I=$O(^TMP("LRC",$J,I)) Q:I<1 S X=^(I,0),LINE=X D SETLINE(LINE,.LCNT)
.. K ^TMP("LRC",$J)
. I SS="CH",$O(^TMP("LRRR",$J,+ORVP,SS,IVDT,0)) D Q
.. S TST=0 F S TST=$O(^TMP("LRRR",$J,+ORVP,SS,IVDT,TST)) Q:TST="" S CC=0,Y="",TCNT=TCNT+1,X=$S(TST:^TMP("LRRR",$J,+ORVP,SS,IVDT,TST),1:"") D
... I TCNT=1 D
.... S LINE="Previous 5 sets of related results within 5 years... " D SETLINE(LINE,.LCNT)
.... D BLANK^ORCXPND
.... S CC=0,LINE=$$S(1,CC," ")_$$S(1,CC,"Collection Time")_$$S(21,CC,"Test Name")_$$S(58,CC,"Result")_$$S(66,CC,"Units")_$$S(82,CC,"Range")
.... D SETLINE(LINE,.LCNT)
.... S CC=0,LINE=$$S(1,CC," ")_$$S(1,CC,"------------------")_$$S(21,CC,"---------")_$$S(58,CC,"------")_$$S(66,CC,"-----")_$$S(82,CC,"-----")
.... D SETLINE(LINE,.LCNT)
... I TST S X=^TMP("LRRR",$J,+ORVP,SS,IVDT,TST),CC=0 I +X D
.... I NDT=1,$P(IDE,";",5)=IVDT S STAR="*"
.... S LNM=$S($L($P(^LAB(60,+X,0),U))>25:$S($L($P($G(^(.1)),U)):$P(^(.1),U),1:$E($P(^(0),U),1,25)),1:$E($P(^(0),U),1,25))
.... S LINE=STAR_$S(NDT=1:$$S(1,CC,$$FMTE^XLFDT(9999999-IVDT,"1M")),1:$$S(1,CC," "))_$$S(20,CC,LNM)_$$S(43,CC,$J($P(X,U,2),20))
.... S LINE=LINE_$$S(49,CC,$S($L($P(X,U,3)):$P(X,U,3),1:""))_$$S(65,CC,$P(X,U,4))_$$S(75,CC,$J($P(X,U,5),15))
.... D SETLINE(LINE,.LCNT)
.... S NDT=0
... I TST="N" S LINE=" Comments: " D SETLINE(LINE,.LCNT) D
.... N CMT S CMT=0 F S CMT=$O(^TMP("LRRR",$J,+ORVP,SS,IVDT,"N",CMT)) Q:'CMT S LINE=" "_^TMP("LRRR",$J,+ORVP,SS,IVDT,"N",CMT) D SETLINE(LINE,.LCNT)
K ^TMP("LRRR",$J),^TMP("LRAPI",$J)
Q
SETLINE(LINE,CNT) ;
S CNT=CNT+1,^TMP("ORXPND",$J,CNT,0)=LINE
Q
;
CONSULTS ; -- consults
N I,X,SUB,ORTX
I $G(ORTAB)="CONSULTS" S X=$P($G(^TMP("OR",$J,ORTAB,"IDX",NUM)),U,4)
E D TEXT^ORQ12(.ORTX,+ID) S X=ORTX(1),ID=+$G(^OR(100,+ID,4)) ; OE->GMRC order#
D ITEM^ORCXPND(X),BLANK^ORCXPND
I ID'>0 S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="No data available." Q
I '$G(ORESULTS) D ;DT action
. S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Consult No.: "_ID
. N GMRCOER S GMRCOER=2 D DT^GMRCSLM2(ID) S SUB="DT"
I $G(ORESULTS) D RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")") S SUB="RT"
S I=0 F S I=$O(^TMP("GMRCR",$J,SUB,I)) Q:I'>0 S X=$G(^(I,0)),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X
K ^TMP("GMRCR",$J)
Q
;
XRAYS ; -- Radiology
I '$G(ORESULTS) S ID=+ORVP_U_$TR(ID,"-","^") D EN3^RAO7PC3(ID)
I $G(ORESULTS) S ID=+$G(^OR(100,+ID,4)) D EN30^RAO7PC3(ID)
N CASE,PROC,PSET
S PSET=$D(^TMP($J,"RAE3",+ORVP,"PRINT_SET")),CASE=0
F S CASE=$O(^TMP($J,"RAE3",+ORVP,CASE)) Q:CASE'>0 D
. I PSET S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,"")) D ITEM^ORCXPND(PROC) Q
. S PROC="" F S PROC=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC)) Q:PROC="" D ITEM^ORCXPND(PROC),BLANK^ORCXPND,XRPT,BLANK^ORCXPND
I PSET S CASE=$O(^TMP($J,"RAE3",+ORVP,0)),PROC=$O(^(CASE,"")) D BLANK^ORCXPND,XRPT,BLANK^ORCXPND ;printset=list all procs, then one report
K ^TMP($J,"RAE3",+ORVP) S VALM("RM")=81
Q
XRPT ; -- body of report for CASE, PROC
N ORD,X,I
S ORD=$S($L($G(^TMP($J,"RAE3",+ORVP,"ORD"))):^("ORD"),$L($G(^("ORD",CASE))):^(CASE),1:"") I $L(ORD),ORD'=PROC S LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)="Proc Ord: "_ORD
S I=1 F S I=$O(^TMP($J,"RAE3",+ORVP,CASE,PROC,I)) Q:I'>0 S X=^(I),LCNT=LCNT+1,^TMP("ORXPND",$J,LCNT,0)=X ;Skip pt ID on line 1
Q
;
S(X,Y,Z) ;Pad over
;X=Column #
;Y=Current length
;Z=Text
;SP=TEXT SENT
;CC=Line position after input text
I '$D(Z) Q ""
N SP S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z
S CC=$$INC(CC,SP)
Q SP
INC(X,Y) ;Character position count
;X=Current count
;Y=Text
N INC S INC=X+$L(Y)
Q INC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWOR2 6111 printed Dec 13, 2024@02:36:51 Page 2
ORWOR2 ;SLC/DCM - RESULT RPC FUNCTIONS ;04/28/2015 11:32
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,350,423**;Dec 17, 1997;Build 19
ORDHIST ; -- orders - compare with ORDERS^ORCXPND1
+1 IF '$GET(ORESULTS)
DO ORDERS^ORCXPND2
QUIT
+2 ; -- Result History Display (Add more packages as available)
+3 NEW PKG,TAB,ORIFN
+4 SET PKG=+$PIECE($GET(^OR(100,+ID,0)),"^",14)
SET PKG=$$NMSP^ORCD(PKG)
+5 SET TAB=$SELECT(PKG="LR":"LABS",PKG="GMRC":"CONSULTS",PKG="RA":"XRAYS",1:"")
+6 ; no display available
IF '$LENGTH(TAB)!(ID'>0)
Begin DoDot:1
+7 NEW ORY,I
+8 DO TEXT^ORQ12(.ORY,+ID,80)
+9 SET I=0
FOR
SET I=$ORDER(ORY(I))
if I'>0
QUIT
DO ITEM^ORCXPND(ORY(I))
+10 DO BLANK^ORCXPND
+11 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="There are no results to report in this time range."
End DoDot:1
QUIT
+12 IF $ORDER(^OR(100,+ID,2,0))
SET ORIFN=+ID
SET ID=0
FOR
SET ID=$ORDER(^OR(100,ORIFN,2,ID))
if ID<1
QUIT
IF $DATA(^OR(100,ID,0))
DO @TAB
+13 IF '$ORDER(^OR(100,+ID,2,0))
DO @TAB
+14 QUIT
LABS ; -- laboratory [RESULTS ONLY for ID=OE order #]
+1 NEW ORIFN,X,Y,SUB,NAME,SS,IDE,IVDT,TST,CC,ORCY,IG,TCNT,ITEM,ORY,SDATE,EDATE,ITDATE,ITMDATE,NDT,STAR,LNM,LINE
+2 KILL ^TMP("LRRR",$JOB),^TMP("LRAPI",$JOB)
+3 SET ORIFN=+ID
SET IDE=$GET(^OR(100,+ID,4))
+4 ; OE# -> Lab#
if '$LENGTH(IDE)
QUIT
+5 SET ITEM=$$VALUE^ORX8(ID,"ORDERABLE",,"I")
SET ITMDATE=$SELECT($PIECE(ID,";",2):$PIECE($GET(^OR(100,ORIFN,8,$PIECE(ID,";",2),0)),"^",16),1:$PIECE(^OR(100,ORIFN,0),"^",8))
SET ITDATE=$$FMTE^XLFDT(ITMDATE,"1M")
+6 if 'ITEM
QUIT
+7 SET ITEM=+$PIECE($GET(^ORD(101.43,+ITEM,0)),"^",2)
+8 SET $PIECE(IDE,";",1,3)=";;"
+9 ;Set for previous 5 years
SET SDATE=9999999-$SELECT($PIECE(IDE,";",5):$PIECE(IDE,";",5),1:ITMDATE)
SET EDATE=$$FMADD^XLFDT(DT,-1825)
+10 DO RR^LR7OR1(+ORVP,,SDATE,EDATE,,ITEM,,5)
+11 KILL ORCY
DO TEXT^ORQ12(.ORCY,ORIFN,80)
+12 SET IG=0
FOR
SET IG=$ORDER(ORCY(IG))
if IG<1
QUIT
SET X=ORCY(IG)
DO ITEM^ORCXPND(X)
+13 DO BLANK^ORCXPND
+14 IF '$DATA(^TMP("LRRR",$JOB,+ORVP))
SET LINE="No data available."
DO SETLINE(LINE,.LCNT)
QUIT
+15 SET LINE=$SELECT('$PIECE(IDE,";",5):"(Results not yet available for this order)",1:"(* Results for this order)")
+16 DO SETLINE(LINE,.LCNT)
+17 SET CC=0
SET SS=""
SET TCNT=0
+18 FOR
SET SS=$ORDER(^TMP("LRRR",$JOB,+ORVP,SS))
if SS=""
QUIT
SET IVDT=0
FOR
SET IVDT=$ORDER(^TMP("LRRR",$JOB,+ORVP,SS,IVDT))
if 'IVDT
QUIT
Begin DoDot:1
+19 SET NDT=1
SET STAR=" "
+20 IF SS="BB"
KILL ^TMP("LRC",$JOB)
DO EN1^LR7OSBR(+ORVP)
if '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:2
+21 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
if I<1
QUIT
SET X=^(I,0)
SET LINE=X
DO SETLINE(LINE,.LCNT)
+22 KILL ^TMP("LRC",$JOB)
End DoDot:2
QUIT
+23 IF SS="MI"
KILL ^TMP("LRC",$JOB)
DO EN^LR7OSMZ0(+ORVP)
if '$DATA(^TMP("LRC",$JOB))
QUIT
Begin DoDot:2
+24 SET LINE="Previous 5 sets of related results within 5 years... "
DO SETLINE(LINE,.LCNT)
+25 NEW I
SET I=0
FOR
SET I=$ORDER(^TMP("LRC",$JOB,I))
if I<1
QUIT
SET X=^(I,0)
SET LINE=X
DO SETLINE(LINE,.LCNT)
+26 KILL ^TMP("LRC",$JOB)
End DoDot:2
QUIT
+27 IF SS="CH"
IF $ORDER(^TMP("LRRR",$JOB,+ORVP,SS,IVDT,0))
Begin DoDot:2
+28 SET TST=0
FOR
SET TST=$ORDER(^TMP("LRRR",$JOB,+ORVP,SS,IVDT,TST))
if TST=""
QUIT
SET CC=0
SET Y=""
SET TCNT=TCNT+1
SET X=$SELECT(TST:^TMP("LRRR",$JOB,+ORVP,SS,IVDT,TST),1:"")
Begin DoDot:3
+29 IF TCNT=1
Begin DoDot:4
+30 SET LINE="Previous 5 sets of related results within 5 years... "
DO SETLINE(LINE,.LCNT)
+31 DO BLANK^ORCXPND
+32 SET CC=0
SET LINE=$$S(1,CC," ")_$$S(1,CC,"Collection Time")_$$S(21,CC,"Test Name")_$$S(58,CC,"Result")_$$S(66,CC,"Units")_$$S(82,CC,"Range")
+33 DO SETLINE(LINE,.LCNT)
+34 SET CC=0
SET LINE=$$S(1,CC," ")_$$S(1,CC,"------------------")_$$S(21,CC,"---------")_$$S(58,CC,"------")_$$S(66,CC,"-----")_$$S(82,CC,"-----")
+35 DO SETLINE(LINE,.LCNT)
End DoDot:4
+36 IF TST
SET X=^TMP("LRRR",$JOB,+ORVP,SS,IVDT,TST)
SET CC=0
IF +X
Begin DoDot:4
+37 IF NDT=1
IF $PIECE(IDE,";",5)=IVDT
SET STAR="*"
+38 SET LNM=$SELECT($LENGTH($PIECE(^LAB(60,+X,0),U))>25:$SELECT($LENGTH($PIECE($GET(^(.1)),U)):$PIECE(^(.1),U),1:$EXTRACT($PIECE(^(0),U),1,25)),1:$EXTRACT($PIECE(^(0),U),1,25))
+39 SET LINE=STAR_$SELECT(NDT=1:$$S(1,CC,$$FMTE^XLFDT(9999999-IVDT,"1M")),1:$$S(1,CC," "))_$$S(20,CC,LNM)_$$S(43,CC,$JUSTIFY($PIECE(X,U,2),20))
+40 SET LINE=LINE_$$S(49,CC,$SELECT($LENGTH($PIECE(X,U,3)):$PIECE(X,U,3),1:""))_$$S(65,CC,$PIECE(X,U,4))_$$S(75,CC,$JUSTIFY($PIECE(X,U,5),15))
+41 DO SETLINE(LINE,.LCNT)
+42 SET NDT=0
End DoDot:4
+43 IF TST="N"
SET LINE=" Comments: "
DO SETLINE(LINE,.LCNT)
Begin DoDot:4
+44 NEW CMT
SET CMT=0
FOR
SET CMT=$ORDER(^TMP("LRRR",$JOB,+ORVP,SS,IVDT,"N",CMT))
if 'CMT
QUIT
SET LINE=" "_^TMP("LRRR",$JOB,+ORVP,SS,IVDT,"N",CMT)
DO SETLINE(LINE,.LCNT)
End DoDot:4
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
if SS="MI"
QUIT
if SS="BB"
QUIT
+45 KILL ^TMP("LRRR",$JOB),^TMP("LRAPI",$JOB)
+46 QUIT
SETLINE(LINE,CNT) ;
+1 SET CNT=CNT+1
SET ^TMP("ORXPND",$JOB,CNT,0)=LINE
+2 QUIT
+3 ;
CONSULTS ; -- consults
+1 NEW I,X,SUB,ORTX
+2 IF $GET(ORTAB)="CONSULTS"
SET X=$PIECE($GET(^TMP("OR",$JOB,ORTAB,"IDX",NUM)),U,4)
+3 ; OE->GMRC order#
IF '$TEST
DO TEXT^ORQ12(.ORTX,+ID)
SET X=ORTX(1)
SET ID=+$GET(^OR(100,+ID,4))
+4 DO ITEM^ORCXPND(X)
DO BLANK^ORCXPND
+5 IF ID'>0
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="No data available."
QUIT
+6 ;DT action
IF '$GET(ORESULTS)
Begin DoDot:1
+7 SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="Consult No.: "_ID
+8 NEW GMRCOER
SET GMRCOER=2
DO DT^GMRCSLM2(ID)
SET SUB="DT"
End DoDot:1
+9 IF $GET(ORESULTS)
DO RT^GMRCGUIA(ID,"^TMP(""GMRCR"",$J,""RT"")")
SET SUB="RT"
+10 SET I=0
FOR
SET I=$ORDER(^TMP("GMRCR",$JOB,SUB,I))
if I'>0
QUIT
SET X=$GET(^(I,0))
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+11 KILL ^TMP("GMRCR",$JOB)
+12 QUIT
+13 ;
XRAYS ; -- Radiology
+1 IF '$GET(ORESULTS)
SET ID=+ORVP_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC3(ID)
+2 IF $GET(ORESULTS)
SET ID=+$GET(^OR(100,+ID,4))
DO EN30^RAO7PC3(ID)
+3 NEW CASE,PROC,PSET
+4 SET PSET=$DATA(^TMP($JOB,"RAE3",+ORVP,"PRINT_SET"))
SET CASE=0
+5 FOR
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE))
if CASE'>0
QUIT
Begin DoDot:1
+6 IF PSET
SET PROC=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,""))
DO ITEM^ORCXPND(PROC)
QUIT
+7 SET PROC=""
FOR
SET PROC=$ORDER(^TMP($JOB,"RAE3",+ORVP,CASE,PROC))
if PROC=""
QUIT
DO ITEM^ORCXPND(PROC)
DO BLANK^ORCXPND
DO XRPT
DO BLANK^ORCXPND
End DoDot:1
+8 ;printset=list all procs, then one report
IF PSET
SET CASE=$ORDER(^TMP($JOB,"RAE3",+ORVP,0))
SET PROC=$ORDER(^(CASE,""))
DO BLANK^ORCXPND
DO XRPT
DO BLANK^ORCXPND
+9 KILL ^TMP($JOB,"RAE3",+ORVP)
SET VALM("RM")=81
+10 QUIT
XRPT ; -- body of report for CASE, PROC
+1 NEW ORD,X,I
+2 SET ORD=$SELECT($LENGTH($GET(^TMP($JOB,"RAE3",+ORVP,"ORD"))):^("ORD"),$LENGTH($GET(^("ORD",CASE))):^(CASE),1:"")
IF $LENGTH(ORD)
IF ORD'=PROC
SET LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)="Proc Ord: "_ORD
+3 ;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 LCNT=LCNT+1
SET ^TMP("ORXPND",$JOB,LCNT,0)=X
+4 QUIT
+5 ;
S(X,Y,Z) ;Pad over
+1 ;X=Column #
+2 ;Y=Current length
+3 ;Z=Text
+4 ;SP=TEXT SENT
+5 ;CC=Line position after input text
+6 IF '$DATA(Z)
QUIT ""
+7 NEW SP
SET SP=Z
IF X
IF Y
IF X>Y
SET SP=$EXTRACT(" ",1,X-Y)_Z
+8 SET CC=$$INC(CC,SP)
+9 QUIT SP
INC(X,Y) ;Character position count
+1 ;X=Current count
+2 ;Y=Text
+3 NEW INC
SET INC=X+$LENGTH(Y)
+4 QUIT INC
