LR7OU1.m

LR7OU1 ;slc/dcm - General Utilities ;8/11/97 [ 04/25/2003  10:17 AM ]

 ;;5.2T9;LR;**1018**;Nov 17, 2004

 ;;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

LR7OU1    ;slc/dcm - General Utilities ;8/11/97 [ 04/25/2003  10:17 AM ]

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**121,187,235**;Sep 27, 1994

 +3       ;

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