LR7OGMP ;VA/DALOI/STAFF- Interim report rpc memo print ; 03-Jul-2014 07:41 ; MKK
;;5.2;LAB SERVICE;**1027,1031,1033**;NOV 01, 1997;Build 146
;
;;VA LR Patche(s): 187,246,282,286,344,395
;
PRINT(OUTCNT) ; from LR7OGMC
NEW ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,HIGH,IDT,INTP,LINE,LOW,LRCW,LRX,PORDER,PRNTCODE
NEW RANGE,REFHIGH,REFLOW,SEX,SITE,SPEC,SUB,TESTNUM
NEW TESTSPEC,THER,THERHIGH,THERLOW,UNITS,VALUE,X,ZERO
;
NEW LRPLS,TIDT,SITECNT ; IHS/OIT/MKK - LR*5.2*1027
;
; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
S AGE=$P(^TMP("LR7OG",$J,"G"),U,4),SEX=$P(^("G"),U,5),LRCW=$P(^("G"),U,6)
S CDT=0
S SITECNT=0 ; IHS/OIT/MKK - LR*5.*1027
F S CDT=$O(^TMP("LR7OG",$J,"TP",CDT)) Q:CDT="" D
. S IDT=9999999-CDT
. S ZERO=$S($D(^TMP("LR7OG",$J,"TP",CDT))#2:^(CDT),1:"")
. S SPEC=+$P(ZERO,U,5)
. S DOC=$$NAME(+$P(ZERO,U,10))
. D SETLINE("",.OUTCNT)
. S LINE="Report Released Date/Time: "_$$FMTE^XLFDT($P(ZERO,"^",3),"M")
. D SETLINE(LINE,.OUTCNT)
. S LINE="Provider: "_DOC
. D SETLINE(LINE,.OUTCNT)
. S LINE=" Specimen: "_$P($G(^LAB(61,SPEC,0),"<no specimen on file>"),U)_"."
. S ACC=$P(ZERO,U,6)
. S LINE=$$SETSTR^VALM1(" "_ACC,LINE,30,1+$L(ACC))
. D SETLINE(LINE,.OUTCNT)
. D SETLINE(" Specimen Collection Date: "_$$LRUDT^LR7OSUM6(CDT),.OUTCNT)
. ; D SETLINE(" Test name Result units Ref. range Site Code",.OUTCNT)
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
. D SETLINE(" ",.OUTCNT)
. D SETLINE(" Res",.OUTCNT)
. D SETLINE("Test name Result Flg units Ref. range Site Result Dt/Time",.OUTCNT)
. ; ----- END IHS/MSC/MKK - LR*5.2*1031
. S PORDER=0
. F S PORDER=$O(^TMP("LR7OG",$J,"TP",CDT,PORDER)) Q:PORDER'>0 S DATA=^(PORDER) D
.. I $P(DATA,U,7)="" Q
.. S TESTNUM=+DATA,PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),SITE=$P(DATA,U,11)
.. S:+$G(SITE) SITECNT=SITECNT+1 ; IHS/OIT/MKK - LR*5.*1027
.. S LOW=$P(RANGE,"-"),HIGH=$P(RANGE,"-",2),THER=$P(DATA,U,12)
.. ;
.. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
.. ; NEW REFLOW,REFHIGH
.. ; S REFLOW=$$TRIM^XLFSTR($P($G(RANGE),"-"),"LR"," ")
.. ; S REFHIGH=$$TRIM^XLFSTR($P($G(RANGE),"-",2),"LR"," ")
.. ; D:$L(REFLOW) ZEROFIX(TESTNUM,.REFLOW)
.. ; D:$L(REFHIGH) ZEROFIX(TESTNUM,.REFHIGH)
.. ; I $L(REFLOW)!($L(REFHIGH)) S RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
.. ; K REFLOW,REFHIGH
.. ; ----- END IHS/MSC/MKK - LR*5.2*1031
.. ;
.. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
.. NEW REFLOW,REFHIGH
.. I $$UP^XLFSTR(RANGE)'["REF:" D
... S REFLOW=$$TRIM^XLFSTR($P($G(RANGE),"-"),"LR"," ")
... S REFHIGH=$$TRIM^XLFSTR($P($G(RANGE),"-",2),"LR"," ")
... D:$L(REFLOW) ZEROFIX(TESTNUM,.REFLOW)
... D:$L(REFHIGH) ZEROFIX(TESTNUM,.REFHIGH)
... I $L(REFLOW)!($L(REFHIGH)) S RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
... K REFLOW,REFHIGH
.. I RANGE[" to "&(RANGE["Ref:") S RANGE=$P(RANGE,"Ref: ",2)
.. ; ----- END IHS/MSC/MKK - LR*5.2*1033
.. ;
.. ; I $L($P(DATA,U,2))>28,$P(DATA,U,3)'="" S LINE=$P(DATA,U,3)
.. ; E S LINE=$E($P(DATA,U,2),1,28)
.. S LINE=$S($L($P(DATA,U,2))>15:$P(DATA,U,3),1:$P(DATA,U,2)) ; IHS/MSC/MKK - LR*5.2*1031
.. ; S LINE=$$SETSTR^VALM1("",LINE,28,0)
.. S LINE=$$SETSTR^VALM1("",LINE,17,0) ; IHS/MSC/MKK - LR*5.2*1031
.. ; I PRNTCODE="" S LINE=LINE_$J(X,8)
.. ; E S @("VALUE="_PRNTCODE),LINE=LINE_VALUE
.. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
.. I PRNTCODE="" S VALUE=X
.. I PRNTCODE'="" S @("VALUE="_PRNTCODE)
.. S LINE=$$SETSTR^VALM1($J(VALUE,7),LINE,19,8)
.. ; ----- END IHS/MSC/MKK - LR*5.2*1031
.. S LINE=LINE_" "_FLAG
.. ; I $L(LINE)>38 D SETLINE(LINE,.OUTCNT) S LINE=""
.. ; I UNITS'="" S LINE=$$SETSTR^VALM1(" "_UNITS,LINE,39,2+$L(UNITS))
.. I UNITS'="" S LINE=$$SETSTR^VALM1(UNITS,LINE,31,2+$L(UNITS)) ; IHS/OIT/MKK - LR*5.2*1027
.. I $G(RANGE)["$S(" D MUMPRNGE(.RANGE) ; IHS/OIT/MKK - LR*5.2*1027
.. S LRX=RANGE
.. ; I LRX'="" S LINE=$$SETSTR^VALM1(LRX,LINE,52,$L(LRX))
.. I LRX'="" S LINE=$$SETSTR^VALM1(LRX,LINE,44,$L(LRX)) ; IHS/OIT/MKK - LR*5.2*1027
.. ; I $L(LINE)>67,SITE D SETLINE(LINE,.OUTCNT) S LINE=""
.. ; I SITE S LINE=$$SETSTR^VALM1(" ["_SITE_"]",LINE,68,3+$L(SITE))
.. I SITE S LINE=$$SETSTR^VALM1($J("["_SITE_"]",7),LINE,59,7) ; IHS/OIT/MKK - LR*5.2*1027
.. I IDT S LINE=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P($G(^LR(LRDFN,"CH",IDT,0)),"^",3),"2MZ"),"@"," "),LINE,67,14) ; IHS/OIT/MKK - LR*5.2*1027
.. I LINE'="" D SETLINE(LINE,.OUTCNT)
.. I $O(^TMP("LR7OG",$J,"TP",CDT,PORDER,0))>0 D
... S INTP=0
... F S INTP=+$O(^TMP("LR7OG",$J,"TP",CDT,PORDER,INTP)) Q:INTP<1 D SETLINE(" Eval: "_^(INTP),.OUTCNT)
. I $D(^TMP("LR7OG",$J,"TP",CDT,"C")) D
.. S LINE="Comment: "
.. S CMNT=0
.. F S CMNT=+$O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) Q:CMNT<1 S LINE=LINE_^(CMNT) D
... D SETLINE(LINE,.OUTCNT)
... I $O(^TMP("LR7OG",$J,"TP",CDT,"C",CMNT)) S LINE=" "
. ; D SETLINE("===============================================================================",.OUTCNT)
. D:SITECNT<1 SETLINE($TR($J("",81)," ","="),.OUTCNT) ; IHS/OIT/MKK - LR*5.2*1027
. ; D SETLINE(" ",.OUTCNT)
. D:SITECNT>0 PLS ; IHS/MSC/MKK - LR*5.2*1031
Q
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
NEW LOW,HIGH,RV1,RV2
;
S LOW=$$TRIM^XLFSTR($P(RANGE,"-"),"LR"," ")
S HIGH=$$TRIM^XLFSTR($P(RANGE,"-",2),"LR"," ")
;
I $G(LOW)=""&($G(HIGH)="") S RANGE=" " Q
;
S RV1=$$MUMPEVAL(LOW)
S RV2=$$MUMPEVAL(HIGH)
;
; I $G(RV1)=""&($G(RV2)="") S RANGE=" " Q
;
; S RANGE=RV1_" - "_RV2
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
D:$L(RV1) ZEROFIX(TESTNUM,.RV1)
D:$L(RV2) ZEROFIX(TESTNUM,.RV2)
S RANGE=$$EN^LRLRRVF(RV1,RV2) ; IHS/MSC/MKK - LR*5.2*1031
; ----- END IHS/MSC/MKK - LR*5.2*1031
Q
;
MUMPEVAL(EVAL) ;
NEW STR,WOT
;
; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
; reference range code has been mis-parsed. Return NULL.
I EVAL'["$S(" D Q EVAL
. I EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&") S EVAL=""
;
; If there is an "(" in the string, but no ")", that means the reference range code is too complex
; and/or has been mis-parsed. Return NULL.
I EVAL'[")" Q ""
;
S STR="WOT="_EVAL
S @STR
;
; ANY punctuation in string means parsing failed. Return NULL.
I WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&") S WOT=""
;
Q WOT
;
; ----- END IHS/OIT/MKK - LR*5.2*1027
;
SETLINE(LINE,CNT) ;
S ^TMP("LR7OGX",$J,"OUTPUT",CNT)=LINE
S CNT=CNT+1
Q
;
;
NAME(X) ; $$(#) -> name
N LRDOC
D DOC^LRX
Q LRDOC
;
;
DD(Y) ; $$(date/time) -> date/time format
D DD^LRX
Q Y
;
;
PLS ; List performing laboratories
;
N LINE,LRPLS,X
D SETLINE(" ",.OUTCNT) ; IHS/OIT/MKK -- LR*5.2*1027
D SETLINE("Performing Lab Sites",.OUTCNT)
S LRPLS=0
F S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1 D
. S LINE=$$LJ^XLFSTR("["_LRPLS_"] ",8)_$$NAME^XUAF4(LRPLS)
. D SETLINE(LINE,.OUTCNT)
. S X=$$PADD^XUAF4(LRPLS)
. S LINE=$$REPEAT^XLFSTR(" ",8)_$P(X,U)_" "_$P(X,U,2)_", "_$P(X,U,3)_" "_$P(X,U,4)
. D SETLINE(LINE,.OUTCNT)
;
D SETLINE("===============================================================================",.OUTCNT)
;
K ^TMP("LRPLS",$J)
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX(F60PTR,RESULT) ; EP - Leading & Trailing Zero Fix for Results
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60PTR,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,RESULT,U,XPARSYS,XQXFLG)
;
Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB" ; Skip if not resulted
;
Q:$L($G(RESULT))<1 ; Skip if no Result
Q:$L($G(F60PTR))<1 ; Skip if no File 60 Pointer
;
S DN=+$G(^LAB(60,F60PTR,.2))
Q:DN<1 ; Skip if no DataName
;
Q:$G(^DD(63.04,DN,0))'["^LRNUM" ; Skip if no numeric defintiion
;
S STR=$P($P($G(^DD(63.04,DN,0)),"Q9=",2),$C(34),2) ; Get numeric formatting
;
S DP=+$P(STR,",",3) ; Decimal Places
Q:DP<1 ; Skip if no Decimal Defintion
;
S SYMBOL="",ORIGRSLT=RESULT
F Q:$E(RESULT)="."!($E(RESULT)?1N)!(RESULT="") D ; Adjust if ANY Non-Numeric is at the beginning of RESULT
. S SYMBOL=SYMBOL_$E(RESULT)
. S RESULT=$E(RESULT,2,$L(RESULT))
;
S:$E(RESULT)="." RESULT="0"_RESULT ; Leading Zero Fix
;
I $E(RESULT)'?1N S RESULT=ORIGRSLT Q ; Skip if RESULT has no numeric part
;
S RESULT=$TR($FN(RESULT,"P",DP)," ")
;
S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT ; Restore "symbol", if necessary
;
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
LR7OGMP ;VA/DALOI/STAFF- Interim report rpc memo print ; 03-Jul-2014 07:41 ; MKK
+1 ;;5.2;LAB SERVICE;**1027,1031,1033**;NOV 01, 1997;Build 146
+2 ;
+3 ;;VA LR Patche(s): 187,246,282,286,344,395
+4 ;
PRINT(OUTCNT) ; from LR7OGMC
+1 NEW ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,HIGH,IDT,INTP,LINE,LOW,LRCW,LRX,PORDER,PRNTCODE
+2 NEW RANGE,REFHIGH,REFLOW,SEX,SITE,SPEC,SUB,TESTNUM
+3 NEW TESTSPEC,THER,THERHIGH,THERLOW,UNITS,VALUE,X,ZERO
+4 ;
+5 ; IHS/OIT/MKK - LR*5.2*1027
NEW LRPLS,TIDT,SITECNT
+6 ;
+7 ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
+8 SET AGE=$PIECE(^TMP("LR7OG",$JOB,"G"),U,4)
SET SEX=$PIECE(^("G"),U,5)
SET LRCW=$PIECE(^("G"),U,6)
+9 SET CDT=0
+10 ; IHS/OIT/MKK - LR*5.*1027
SET SITECNT=0
+11 FOR
SET CDT=$ORDER(^TMP("LR7OG",$JOB,"TP",CDT))
IF CDT=""
QUIT
Begin DoDot:1
+12 SET IDT=9999999-CDT
+13 SET ZERO=$SELECT($DATA(^TMP("LR7OG",$JOB,"TP",CDT))#2:^(CDT),1:"")
+14 SET SPEC=+$PIECE(ZERO,U,5)
+15 SET DOC=$$NAME(+$PIECE(ZERO,U,10))
+16 DO SETLINE("",.OUTCNT)
+17 SET LINE="Report Released Date/Time: "_$$FMTE^XLFDT($PIECE(ZERO,"^",3),"M")
+18 DO SETLINE(LINE,.OUTCNT)
+19 SET LINE="Provider: "_DOC
+20 DO SETLINE(LINE,.OUTCNT)
+21 SET LINE=" Specimen: "_$PIECE($GET(^LAB(61,SPEC,0),"<no specimen on file>"),U)_"."
+22 SET ACC=$PIECE(ZERO,U,6)
+23 SET LINE=$$SETSTR^VALM1(" "_ACC,LINE,30,1+$LENGTH(ACC))
+24 DO SETLINE(LINE,.OUTCNT)
+25 DO SETLINE(" Specimen Collection Date: "_$$LRUDT^LR7OSUM6(CDT),.OUTCNT)
+26 ; D SETLINE(" Test name Result units Ref. range Site Code",.OUTCNT)
+27 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+28 DO SETLINE(" ",.OUTCNT)
+29 DO SETLINE(" Res",.OUTCNT)
+30 DO SETLINE("Test name Result Flg units Ref. range Site Result Dt/Time",.OUTCNT)
+31 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+32 SET PORDER=0
+33 FOR
SET PORDER=$ORDER(^TMP("LR7OG",$JOB,"TP",CDT,PORDER))
IF PORDER'>0
QUIT
SET DATA=^(PORDER)
Begin DoDot:2
+34 IF $PIECE(DATA,U,7)=""
QUIT
+35 SET TESTNUM=+DATA
SET PRNTCODE=$PIECE(DATA,U,5)
SET SUB=$PIECE(DATA,U,6)
SET FLAG=$PIECE(DATA,U,8)
SET X=$PIECE(DATA,U,7)
SET UNITS=$PIECE(DATA,U,9)
SET RANGE=$PIECE(DATA,U,10)
SET SITE=$PIECE(DATA,U,11)
+36 ; IHS/OIT/MKK - LR*5.*1027
IF +$GET(SITE)
SET SITECNT=SITECNT+1
+37 SET LOW=$PIECE(RANGE,"-")
SET HIGH=$PIECE(RANGE,"-",2)
SET THER=$PIECE(DATA,U,12)
+38 ;
+39 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+40 ; NEW REFLOW,REFHIGH
+41 ; S REFLOW=$$TRIM^XLFSTR($P($G(RANGE),"-"),"LR"," ")
+42 ; S REFHIGH=$$TRIM^XLFSTR($P($G(RANGE),"-",2),"LR"," ")
+43 ; D:$L(REFLOW) ZEROFIX(TESTNUM,.REFLOW)
+44 ; D:$L(REFHIGH) ZEROFIX(TESTNUM,.REFHIGH)
+45 ; I $L(REFLOW)!($L(REFHIGH)) S RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
+46 ; K REFLOW,REFHIGH
+47 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+48 ;
+49 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
+50 NEW REFLOW,REFHIGH
+51 IF $$UP^XLFSTR(RANGE)'["REF:"
Begin DoDot:3
+52 SET REFLOW=$$TRIM^XLFSTR($PIECE($GET(RANGE),"-"),"LR"," ")
+53 SET REFHIGH=$$TRIM^XLFSTR($PIECE($GET(RANGE),"-",2),"LR"," ")
+54 IF $LENGTH(REFLOW)
DO ZEROFIX(TESTNUM,.REFLOW)
+55 IF $LENGTH(REFHIGH)
DO ZEROFIX(TESTNUM,.REFHIGH)
+56 IF $LENGTH(REFLOW)!($LENGTH(REFHIGH))
SET RANGE=$$EN^LRLRRVF(REFLOW,REFHIGH)
+57 KILL REFLOW,REFHIGH
End DoDot:3
+58 IF RANGE[" to "&(RANGE["Ref:")
SET RANGE=$PIECE(RANGE,"Ref: ",2)
+59 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+60 ;
+61 ; I $L($P(DATA,U,2))>28,$P(DATA,U,3)'="" S LINE=$P(DATA,U,3)
+62 ; E S LINE=$E($P(DATA,U,2),1,28)
+63 ; IHS/MSC/MKK - LR*5.2*1031
SET LINE=$SELECT($LENGTH($PIECE(DATA,U,2))>15:$PIECE(DATA,U,3),1:$PIECE(DATA,U,2))
+64 ; S LINE=$$SETSTR^VALM1("",LINE,28,0)
+65 ; IHS/MSC/MKK - LR*5.2*1031
SET LINE=$$SETSTR^VALM1("",LINE,17,0)
+66 ; I PRNTCODE="" S LINE=LINE_$J(X,8)
+67 ; E S @("VALUE="_PRNTCODE),LINE=LINE_VALUE
+68 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+69 IF PRNTCODE=""
SET VALUE=X
+70 IF PRNTCODE'=""
SET @("VALUE="_PRNTCODE)
+71 SET LINE=$$SETSTR^VALM1($JUSTIFY(VALUE,7),LINE,19,8)
+72 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+73 SET LINE=LINE_" "_FLAG
+74 ; I $L(LINE)>38 D SETLINE(LINE,.OUTCNT) S LINE=""
+75 ; I UNITS'="" S LINE=$$SETSTR^VALM1(" "_UNITS,LINE,39,2+$L(UNITS))
+76 ; IHS/OIT/MKK - LR*5.2*1027
IF UNITS'=""
SET LINE=$$SETSTR^VALM1(UNITS,LINE,31,2+$LENGTH(UNITS))
+77 ; IHS/OIT/MKK - LR*5.2*1027
IF $GET(RANGE)["$S("
DO MUMPRNGE(.RANGE)
+78 SET LRX=RANGE
+79 ; I LRX'="" S LINE=$$SETSTR^VALM1(LRX,LINE,52,$L(LRX))
+80 ; IHS/OIT/MKK - LR*5.2*1027
IF LRX'=""
SET LINE=$$SETSTR^VALM1(LRX,LINE,44,$LENGTH(LRX))
+81 ; I $L(LINE)>67,SITE D SETLINE(LINE,.OUTCNT) S LINE=""
+82 ; I SITE S LINE=$$SETSTR^VALM1(" ["_SITE_"]",LINE,68,3+$L(SITE))
+83 ; IHS/OIT/MKK - LR*5.2*1027
IF SITE
SET LINE=$$SETSTR^VALM1($JUSTIFY("["_SITE_"]",7),LINE,59,7)
+84 ; IHS/OIT/MKK - LR*5.2*1027
IF IDT
SET LINE=$$SETSTR^VALM1($TRANSLATE($$FMTE^XLFDT($PIECE($GET(^LR(LRDFN,"CH",IDT,0)),"^",3),"2MZ"),"@"," "),LINE,67,14)
+85 IF LINE'=""
DO SETLINE(LINE,.OUTCNT)
+86 IF $ORDER(^TMP("LR7OG",$JOB,"TP",CDT,PORDER,0))>0
Begin DoDot:3
+87 SET INTP=0
+88 FOR
SET INTP=+$ORDER(^TMP("LR7OG",$JOB,"TP",CDT,PORDER,INTP))
IF INTP<1
QUIT
DO SETLINE(" Eval: "_^(INTP),.OUTCNT)
End DoDot:3
End DoDot:2
+89 IF $DATA(^TMP("LR7OG",$JOB,"TP",CDT,"C"))
Begin DoDot:2
+90 SET LINE="Comment: "
+91 SET CMNT=0
+92 FOR
SET CMNT=+$ORDER(^TMP("LR7OG",$JOB,"TP",CDT,"C",CMNT))
IF CMNT<1
QUIT
SET LINE=LINE_^(CMNT)
Begin DoDot:3
+93 DO SETLINE(LINE,.OUTCNT)
+94 IF $ORDER(^TMP("LR7OG",$JOB,"TP",CDT,"C",CMNT))
SET LINE=" "
End DoDot:3
End DoDot:2
+95 ; D SETLINE("===============================================================================",.OUTCNT)
+96 ; IHS/OIT/MKK - LR*5.2*1027
IF SITECNT<1
DO SETLINE($TRANSLATE($JUSTIFY("",81)," ","="),.OUTCNT)
+97 ; D SETLINE(" ",.OUTCNT)
+98 ; IHS/MSC/MKK - LR*5.2*1031
IF SITECNT>0
DO PLS
End DoDot:1
+99 QUIT
+100 ;
+101 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
+1 NEW LOW,HIGH,RV1,RV2
+2 ;
+3 SET LOW=$$TRIM^XLFSTR($PIECE(RANGE,"-"),"LR"," ")
+4 SET HIGH=$$TRIM^XLFSTR($PIECE(RANGE,"-",2),"LR"," ")
+5 ;
+6 IF $GET(LOW)=""&($GET(HIGH)="")
SET RANGE=" "
QUIT
+7 ;
+8 SET RV1=$$MUMPEVAL(LOW)
+9 SET RV2=$$MUMPEVAL(HIGH)
+10 ;
+11 ; I $G(RV1)=""&($G(RV2)="") S RANGE=" " Q
+12 ;
+13 ; S RANGE=RV1_" - "_RV2
+14 ;
+15 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+16 IF $LENGTH(RV1)
DO ZEROFIX(TESTNUM,.RV1)
+17 IF $LENGTH(RV2)
DO ZEROFIX(TESTNUM,.RV2)
+18 ; IHS/MSC/MKK - LR*5.2*1031
SET RANGE=$$EN^LRLRRVF(RV1,RV2)
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+20 QUIT
+21 ;
MUMPEVAL(EVAL) ;
+1 NEW STR,WOT
+2 ;
+3 ; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
+4 ; reference range code has been mis-parsed. Return NULL.
+5 IF EVAL'["$S("
Begin DoDot:1
+6 IF EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&")
SET EVAL=""
End DoDot:1
QUIT EVAL
+7 ;
+8 ; If there is an "(" in the string, but no ")", that means the reference range code is too complex
+9 ; and/or has been mis-parsed. Return NULL.
+10 IF EVAL'[")"
QUIT ""
+11 ;
+12 SET STR="WOT="_EVAL
+13 SET @STR
+14 ;
+15 ; ANY punctuation in string means parsing failed. Return NULL.
+16 IF WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&")
SET WOT=""
+17 ;
+18 QUIT WOT
+19 ;
+20 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+21 ;
SETLINE(LINE,CNT) ;
+1 SET ^TMP("LR7OGX",$JOB,"OUTPUT",CNT)=LINE
+2 SET CNT=CNT+1
+3 QUIT
+4 ;
+5 ;
NAME(X) ; $$(#) -> name
+1 NEW LRDOC
+2 DO DOC^LRX
+3 QUIT LRDOC
+4 ;
+5 ;
DD(Y) ; $$(date/time) -> date/time format
+1 DO DD^LRX
+2 QUIT Y
+3 ;
+4 ;
PLS ; List performing laboratories
+1 ;
+2 NEW LINE,LRPLS,X
+3 ; IHS/OIT/MKK -- LR*5.2*1027
DO SETLINE(" ",.OUTCNT)
+4 DO SETLINE("Performing Lab Sites",.OUTCNT)
+5 SET LRPLS=0
+6 FOR
SET LRPLS=$ORDER(^TMP("LRPLS",$JOB,LRPLS))
IF LRPLS<1
QUIT
Begin DoDot:1
+7 SET LINE=$$LJ^XLFSTR("["_LRPLS_"] ",8)_$$NAME^XUAF4(LRPLS)
+8 DO SETLINE(LINE,.OUTCNT)
+9 SET X=$$PADD^XUAF4(LRPLS)
+10 SET LINE=$$REPEAT^XLFSTR(" ",8)_$PIECE(X,U)_" "_$PIECE(X,U,2)_", "_$PIECE(X,U,3)_" "_$PIECE(X,U,4)
+11 DO SETLINE(LINE,.OUTCNT)
End DoDot:1
+12 ;
+13 DO SETLINE("===============================================================================",.OUTCNT)
+14 ;
+15 KILL ^TMP("LRPLS",$JOB)
+16 QUIT
+17 ;
+18 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX(F60PTR,RESULT) ; EP - Leading & Trailing Zero Fix for Results
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60PTR,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,RESULT,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Skip if not resulted
IF $$UP^XLFSTR($GET(RESULT))["SPECIMEN IN LAB"
QUIT
+4 ;
+5 ; Skip if no Result
IF $LENGTH($GET(RESULT))<1
QUIT
+6 ; Skip if no File 60 Pointer
IF $LENGTH($GET(F60PTR))<1
QUIT
+7 ;
+8 SET DN=+$GET(^LAB(60,F60PTR,.2))
+9 ; Skip if no DataName
IF DN<1
QUIT
+10 ;
+11 ; Skip if no numeric defintiion
IF $GET(^DD(63.04,DN,0))'["^LRNUM"
QUIT
+12 ;
+13 ; Get numeric formatting
SET STR=$PIECE($PIECE($GET(^DD(63.04,DN,0)),"Q9=",2),$CHAR(34),2)
+14 ;
+15 ; Decimal Places
SET DP=+$PIECE(STR,",",3)
+16 ; Skip if no Decimal Defintion
IF DP<1
QUIT
+17 ;
+18 SET SYMBOL=""
SET ORIGRSLT=RESULT
+19 ; Adjust if ANY Non-Numeric is at the beginning of RESULT
FOR
IF $EXTRACT(RESULT)="."!($EXTRACT(RESULT)?1N)!(RESULT="")
QUIT
Begin DoDot:1
+20 SET SYMBOL=SYMBOL_$EXTRACT(RESULT)
+21 SET RESULT=$EXTRACT(RESULT,2,$LENGTH(RESULT))
End DoDot:1
+22 ;
+23 ; Leading Zero Fix
IF $EXTRACT(RESULT)="."
SET RESULT="0"_RESULT
+24 ;
+25 ; Skip if RESULT has no numeric part
IF $EXTRACT(RESULT)'?1N
SET RESULT=ORIGRSLT
QUIT
+26 ;
+27 SET RESULT=$TRANSLATE($FNUMBER(RESULT,"P",DP)," ")
+28 ;
+29 ; Restore "symbol", if necessary
IF $LENGTH($GET(SYMBOL))
SET RESULT=SYMBOL_RESULT
+30 ;
+31 QUIT
+32 ; ----- END IHS/MSC/MKK - LR*5.2*1031
