LR7OU1 ;slc/dcm - General Utilities ;8/11/97
;;5.2;LAB SERVICE;**121,187,235**;Sep 27, 1994
;
EN(TST,SUB) ;Expand a lab panel
;TST=Test ptr to file 60
;SUB=Test subscript $p(^LAB(60,X,0),"^",5)
;TSTY(subscript)=TST Expanded panel put in this array
N S2,J,X
I $L($G(SUB)) S S2=$P(SUB,";",2) S:'$D(TSTY(S2)) TSTY(S2)=+TST Q
S J=0 F S J=$O(^LAB(60,+TST,2,J)) Q:J<1 S X=^(J,0) D EN(+X,$P(^LAB(60,+X,0),"^",5))
Q
TEST ;Test expanding panel
S DIC=60,DIC(0)="ZAEQM" D ^DIC Q:Y<1
N TSTY D EN(+Y,$P(Y(0),"^",5))
;ZW TSTY
Q
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
WC(PK,IFN) ;Get collection type for print fields
N X
S X=$$TYPE($P(PK,";",2),$P(PK,";",3)),Y=$S(X="WC":"Ward Collect",X="LC":"Lab Collect",X="SP":"Send Patient",X="I":"Immediate Collect",1:"")
Q Y
ACC(PK,IFN) ;Get accession numbers for print fields
N X,Y
S X=$$GETST($P(PK,";",2),$P(PK,";",3),IFN),Y="",Y=$P(X,"^",3,5),X=$S($D(^LRO(68,+$P(Y,"^",2),0)):$P(^(0),"^",11),1:""),X=X_" "_$E($P(Y,"^"),4,7)_" "_$P(Y,"^",3)
Q X
LU(PK,IFN) ;Get urgency for print fields
N X
S X=$$GETST($P(PK,";",2),$P(PK,";",3),IFN),X=$P(X,"^",2),X=$S(X:$P(^LAB(62.05,X,0),"^"),1:"")
Q X
COL(PK,IFN) ;Get collection sample with Tube type for print fields
N X,Y
S X=$$SAMP($P(PK,";",2),$P(PK,";",3))
S Y=$S(X:$S($D(^LAB(62,X,0)):$P(^(0),"^")_" "_$P(^(0),"^",3),1:""),1:"")
Q Y
VER() ;Check OE/RR version #
;Returns current OE/RR version #
N VER S VER=$S(+$G(^DD(100,0,"VR")):+^("VR"),1:0)
Q VER
GETTEST(IFN) ;Get Lab test from Order entry
;IFN=Order # from file 100
Q:'$G(IFN) ""
N X
S X=$$VALUE^ORCSAVE2(IFN,"ORDERABLE") Q:'X ""
S X=+$P($G(^ORD(101.43,+X,0)),"^",2)
Q X
GETST(ODT,SN,IFN) ;Find test node from LRODT,LRSN for a given ORIFN
;ODT=LRODT, SN=LRSN, IFN=ORIFN
Q:'$G(ODT) "" Q:'$G(SN) "" Q:'$G(IFN) ""
Q:'$D(^LRO(69,ODT,1,SN,0)) ""
N TST,X,T,END
S X="",(T,END)=0,TST=$$GETTEST(IFN) Q:'TST ""
F S T=$O(^LRO(69,ODT,1,SN,2,T)) Q:T<1!(END) D
. I $D(^LRO(69,ODT,1,SN,2,T,0)),+^(0)=TST S X=^(0),END=1 Q
Q X
GET0(ODT,SN) ;Get zero node: ^LRO(69,ODT,1,SN,0) for an ORIFN
;ODT=LRODT, SN=LRSN
Q:'$G(ODT) "" Q:'$G(SN) ""
Q $G(^LRO(69,ODT,1,SN,0))
SAMP(ODT,SN) ;Get collection sample pointer from lab order
;ODT=LRODT, SN=LRSN
Q $P($$GET0(ODT,SN),"^",3)
TYPE(ODT,SN) ;Get collection type internal value from lab order
;ODT=LRODT, SN=LRSN
Q $P($$GET0(ODT,SN),"^",4)
SAMPCOM(PK,IFN) ;Get Ward Remarks (specimen) for lab order
N TEST,SPEC
S TEST=+$$GETST($P(PK,";",2),$P(PK,";",3),IFN) I 'TEST Q ""
S SPEC=$$SAMP($P(PK,";",2),$P(PK,";",3)) I 'SPEC Q ""
S SPEC=$O(^LAB(60,TEST,3,"B",SPEC,0)) I 'SPEC Q ""
Q "^LAB(60,"_TEST_",3,"_SPEC_",1)"
WARDCOM(PK,IFN) ;Get General Ward comments on a test order
N TEST
S TEST=+$$GETST($P(PK,";",2),$P(PK,";",3),IFN) I 'TEST Q ""
Q "^LAB(60,"_TEST_",6)"
EXPAND(TEST,ARAY) ;Expand a lab test panel
;TEST=Test ptr to file 60
;Expanded panel returned in ARAY(TEST)
N INARAY
D EX(TEST)
M ARAY=INARAY
Q
EX(TST) ;
N J,X,SUB
Q:'$D(^LAB(60,TST,0)) S SUB=$P(^(0),"^",5)
I $L(SUB) S:'$D(INARAY(+TST)) INARAY(+TST)="" Q
S J=0 F S J=$O(^LAB(60,+TST,2,J)) Q:J<1 S X=^(J,0) D EX(+X)
Q
SPLIT(TXT,ARAY,CTR,LENGTH,PRE,POST) ;Splits text into an array
;Splits text at nearest space from LENGTH value
;Word limit: 150 characters...<150 stored on own node, >150 split
;TXT- text to be split
;ARAY- array to put the text (e.g. "LOCAL", "^TMP(""LRT"",$J)")
;CTR- starting point in array, default=0. Passed by reference so that external counter is incremented.
;LENGTH- length for each array node, default=80
;PRE- optional text to append at the beginning of each array node
;POST- optional text to append at the end of each array node
N END
Q:'$L($G(TXT)) Q:'$L($G(ARAY))
S:'$G(CTR) CTR=0
S:'$G(LENGTH) LENGTH=80
S:'$L($G(PRE)) PRE=""
S:'$L($G(POST)) POST=""
I $L(TXT)'>LENGTH!('$F(TXT," ",LENGTH)),$L(TXT)<150 S CTR=CTR+1,@ARAY@(CTR)=PRE_$$STRIP(TXT)_POST Q
S END=$S($F(TXT," ",LENGTH):$F(TXT," ",LENGTH),1:LENGTH)
S:END>150 END=150
S CTR=CTR+1,@ARAY@(CTR)=PRE_$$STRIP($E(TXT,1,$S(END=LENGTH:END,1:END-1)))_POST
D SPLIT($E(TXT,END,999),ARAY,.CTR,LENGTH,PRE,POST)
Q
STRIP(X) ; -- Strip leading spaces from text X
N I,Y S Y=""
F I=1:1:$L(X) I $E(X,I)'=" " S Y=$E(X,I,999) Q
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OU1 4400 printed Dec 13, 2024@02:05:49 Page 2
LR7OU1 ;slc/dcm - General Utilities ;8/11/97
+1 ;;5.2;LAB SERVICE;**121,187,235**;Sep 27, 1994
+2 ;
EN(TST,SUB) ;Expand a lab panel
+1 ;TST=Test ptr to file 60
+2 ;SUB=Test subscript $p(^LAB(60,X,0),"^",5)
+3 ;TSTY(subscript)=TST Expanded panel put in this array
+4 NEW S2,J,X
+5 IF $LENGTH($GET(SUB))
SET S2=$PIECE(SUB,";",2)
if '$DATA(TSTY(S2))
SET TSTY(S2)=+TST
QUIT
+6 SET J=0
FOR
SET J=$ORDER(^LAB(60,+TST,2,J))
if J<1
QUIT
SET X=^(J,0)
DO EN(+X,$PIECE(^LAB(60,+X,0),"^",5))
+7 QUIT
TEST ;Test expanding panel
+1 SET DIC=60
SET DIC(0)="ZAEQM"
DO ^DIC
if Y<1
QUIT
+2 NEW TSTY
DO EN(+Y,$PIECE(Y(0),"^",5))
+3 ;ZW TSTY
+4 QUIT
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
WC(PK,IFN) ;Get collection type for print fields
+1 NEW X
+2 SET X=$$TYPE($PIECE(PK,";",2),$PIECE(PK,";",3))
SET Y=$SELECT(X="WC":"Ward Collect",X="LC":"Lab Collect",X="SP":"Send Patient",X="I":"Immediate Collect",1:"")
+3 QUIT Y
ACC(PK,IFN) ;Get accession numbers for print fields
+1 NEW X,Y
+2 SET X=$$GETST($PIECE(PK,";",2),$PIECE(PK,";",3),IFN)
SET Y=""
SET Y=$PIECE(X,"^",3,5)
SET X=$SELECT($DATA(^LRO(68,+$PIECE(Y,"^",2),0)):$PIECE(^(0),"^",11),1:"")
SET X=X_" "_$EXTRACT($PIECE(Y,"^"),4,7)_" "_$PIECE(Y,"^",3)
+3 QUIT X
LU(PK,IFN) ;Get urgency for print fields
+1 NEW X
+2 SET X=$$GETST($PIECE(PK,";",2),$PIECE(PK,";",3),IFN)
SET X=$PIECE(X,"^",2)
SET X=$SELECT(X:$PIECE(^LAB(62.05,X,0),"^"),1:"")
+3 QUIT X
COL(PK,IFN) ;Get collection sample with Tube type for print fields
+1 NEW X,Y
+2 SET X=$$SAMP($PIECE(PK,";",2),$PIECE(PK,";",3))
+3 SET Y=$SELECT(X:$SELECT($DATA(^LAB(62,X,0)):$PIECE(^(0),"^")_" "_$PIECE(^(0),"^",3),1:""),1:"")
+4 QUIT Y
VER() ;Check OE/RR version #
+1 ;Returns current OE/RR version #
+2 NEW VER
SET VER=$SELECT(+$GET(^DD(100,0,"VR")):+^("VR"),1:0)
+3 QUIT VER
GETTEST(IFN) ;Get Lab test from Order entry
+1 ;IFN=Order # from file 100
+2 if '$GET(IFN)
QUIT ""
+3 NEW X
+4 SET X=$$VALUE^ORCSAVE2(IFN,"ORDERABLE")
if 'X
QUIT ""
+5 SET X=+$PIECE($GET(^ORD(101.43,+X,0)),"^",2)
+6 QUIT X
GETST(ODT,SN,IFN) ;Find test node from LRODT,LRSN for a given ORIFN
+1 ;ODT=LRODT, SN=LRSN, IFN=ORIFN
+2 if '$GET(ODT)
QUIT ""
if '$GET(SN)
QUIT ""
if '$GET(IFN)
QUIT ""
+3 if '$DATA(^LRO(69,ODT,1,SN,0))
QUIT ""
+4 NEW TST,X,T,END
+5 SET X=""
SET (T,END)=0
SET TST=$$GETTEST(IFN)
if 'TST
QUIT ""
+6 FOR
SET T=$ORDER(^LRO(69,ODT,1,SN,2,T))
if T<1!(END)
QUIT
Begin DoDot:1
+7 IF $DATA(^LRO(69,ODT,1,SN,2,T,0))
IF +^(0)=TST
SET X=^(0)
SET END=1
QUIT
End DoDot:1
+8 QUIT X
GET0(ODT,SN) ;Get zero node: ^LRO(69,ODT,1,SN,0) for an ORIFN
+1 ;ODT=LRODT, SN=LRSN
+2 if '$GET(ODT)
QUIT ""
if '$GET(SN)
QUIT ""
+3 QUIT $GET(^LRO(69,ODT,1,SN,0))
SAMP(ODT,SN) ;Get collection sample pointer from lab order
+1 ;ODT=LRODT, SN=LRSN
+2 QUIT $PIECE($$GET0(ODT,SN),"^",3)
TYPE(ODT,SN) ;Get collection type internal value from lab order
+1 ;ODT=LRODT, SN=LRSN
+2 QUIT $PIECE($$GET0(ODT,SN),"^",4)
SAMPCOM(PK,IFN) ;Get Ward Remarks (specimen) for lab order
+1 NEW TEST,SPEC
+2 SET TEST=+$$GETST($PIECE(PK,";",2),$PIECE(PK,";",3),IFN)
IF 'TEST
QUIT ""
+3 SET SPEC=$$SAMP($PIECE(PK,";",2),$PIECE(PK,";",3))
IF 'SPEC
QUIT ""
+4 SET SPEC=$ORDER(^LAB(60,TEST,3,"B",SPEC,0))
IF 'SPEC
QUIT ""
+5 QUIT "^LAB(60,"_TEST_",3,"_SPEC_",1)"
WARDCOM(PK,IFN) ;Get General Ward comments on a test order
+1 NEW TEST
+2 SET TEST=+$$GETST($PIECE(PK,";",2),$PIECE(PK,";",3),IFN)
IF 'TEST
QUIT ""
+3 QUIT "^LAB(60,"_TEST_",6)"
EXPAND(TEST,ARAY) ;Expand a lab test panel
+1 ;TEST=Test ptr to file 60
+2 ;Expanded panel returned in ARAY(TEST)
+3 NEW INARAY
+4 DO EX(TEST)
+5 MERGE ARAY=INARAY
+6 QUIT
EX(TST) ;
+1 NEW J,X,SUB
+2 if '$DATA(^LAB(60,TST,0))
QUIT
SET SUB=$PIECE(^(0),"^",5)
+3 IF $LENGTH(SUB)
if '$DATA(INARAY(+TST))
SET INARAY(+TST)=""
QUIT
+4 SET J=0
FOR
SET J=$ORDER(^LAB(60,+TST,2,J))
if J<1
QUIT
SET X=^(J,0)
DO EX(+X)
+5 QUIT
SPLIT(TXT,ARAY,CTR,LENGTH,PRE,POST) ;Splits text into an array
+1 ;Splits text at nearest space from LENGTH value
+2 ;Word limit: 150 characters...<150 stored on own node, >150 split
+3 ;TXT- text to be split
+4 ;ARAY- array to put the text (e.g. "LOCAL", "^TMP(""LRT"",$J)")
+5 ;CTR- starting point in array, default=0. Passed by reference so that external counter is incremented.
+6 ;LENGTH- length for each array node, default=80
+7 ;PRE- optional text to append at the beginning of each array node
+8 ;POST- optional text to append at the end of each array node
+9 NEW END
+10 if '$LENGTH($GET(TXT))
QUIT
if '$LENGTH($GET(ARAY))
QUIT
+11 if '$GET(CTR)
SET CTR=0
+12 if '$GET(LENGTH)
SET LENGTH=80
+13 if '$LENGTH($GET(PRE))
SET PRE=""
+14 if '$LENGTH($GET(POST))
SET POST=""
+15 IF $LENGTH(TXT)'>LENGTH!('$FIND(TXT," ",LENGTH))
IF $LENGTH(TXT)<150
SET CTR=CTR+1
SET @ARAY@(CTR)=PRE_$$STRIP(TXT)_POST
QUIT
+16 SET END=$SELECT($FIND(TXT," ",LENGTH):$FIND(TXT," ",LENGTH),1:LENGTH)
+17 if END>150
SET END=150
+18 SET CTR=CTR+1
SET @ARAY@(CTR)=PRE_$$STRIP($EXTRACT(TXT,1,$SELECT(END=LENGTH:END,1:END-1)))_POST
+19 DO SPLIT($EXTRACT(TXT,END,999),ARAY,.CTR,LENGTH,PRE,POST)
+20 QUIT
STRIP(X) ; -- Strip leading spaces from text X
+1 NEW I,Y
SET Y=""
+2 FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)'=" "
SET Y=$EXTRACT(X,I,999)
QUIT
+3 QUIT Y
