source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OU1.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1LR7OU1 ;slc/dcm - General Utilities ;8/11/97
2 ;;5.2;LAB SERVICE;**121,187,235**;Sep 27, 1994
3 ;
4EN(TST,SUB) ;Expand a lab panel
5 ;TST=Test ptr to file 60
6 ;SUB=Test subscript $p(^LAB(60,X,0),"^",5)
7 ;TSTY(subscript)=TST Expanded panel put in this array
8 N S2,J,X
9 I $L($G(SUB)) S S2=$P(SUB,";",2) S:'$D(TSTY(S2)) TSTY(S2)=+TST Q
10 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))
11 Q
12TEST ;Test expanding panel
13 S DIC=60,DIC(0)="ZAEQM" D ^DIC Q:Y<1
14 N TSTY D EN(+Y,$P(Y(0),"^",5))
15 ;ZW TSTY
16 Q
17UPPER(X) ; Convert lower case X to UPPER CASE
18 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
19WC(PK,IFN) ;Get collection type for print fields
20 N X
21 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:"")
22 Q Y
23ACC(PK,IFN) ;Get accession numbers for print fields
24 N X,Y
25 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)
26 Q X
27LU(PK,IFN) ;Get urgency for print fields
28 N X
29 S X=$$GETST($P(PK,";",2),$P(PK,";",3),IFN),X=$P(X,"^",2),X=$S(X:$P(^LAB(62.05,X,0),"^"),1:"")
30 Q X
31COL(PK,IFN) ;Get collection sample with Tube type for print fields
32 N X,Y
33 S X=$$SAMP($P(PK,";",2),$P(PK,";",3))
34 S Y=$S(X:$S($D(^LAB(62,X,0)):$P(^(0),"^")_" "_$P(^(0),"^",3),1:""),1:"")
35 Q Y
36VER() ;Check OE/RR version #
37 ;Returns current OE/RR version #
38 N VER S VER=$S(+$G(^DD(100,0,"VR")):+^("VR"),1:0)
39 Q VER
40GETTEST(IFN) ;Get Lab test from Order entry
41 ;IFN=Order # from file 100
42 Q:'$G(IFN) ""
43 N X
44 S X=$$VALUE^ORCSAVE2(IFN,"ORDERABLE") Q:'X ""
45 S X=+$P($G(^ORD(101.43,+X,0)),"^",2)
46 Q X
47GETST(ODT,SN,IFN) ;Find test node from LRODT,LRSN for a given ORIFN
48 ;ODT=LRODT, SN=LRSN, IFN=ORIFN
49 Q:'$G(ODT) "" Q:'$G(SN) "" Q:'$G(IFN) ""
50 Q:'$D(^LRO(69,ODT,1,SN,0)) ""
51 N TST,X,T,END
52 S X="",(T,END)=0,TST=$$GETTEST(IFN) Q:'TST ""
53 F S T=$O(^LRO(69,ODT,1,SN,2,T)) Q:T<1!(END) D
54 . I $D(^LRO(69,ODT,1,SN,2,T,0)),+^(0)=TST S X=^(0),END=1 Q
55 Q X
56GET0(ODT,SN) ;Get zero node: ^LRO(69,ODT,1,SN,0) for an ORIFN
57 ;ODT=LRODT, SN=LRSN
58 Q:'$G(ODT) "" Q:'$G(SN) ""
59 Q $G(^LRO(69,ODT,1,SN,0))
60SAMP(ODT,SN) ;Get collection sample pointer from lab order
61 ;ODT=LRODT, SN=LRSN
62 Q $P($$GET0(ODT,SN),"^",3)
63TYPE(ODT,SN) ;Get collection type internal value from lab order
64 ;ODT=LRODT, SN=LRSN
65 Q $P($$GET0(ODT,SN),"^",4)
66SAMPCOM(PK,IFN) ;Get Ward Remarks (specimen) for lab order
67 N TEST,SPEC
68 S TEST=+$$GETST($P(PK,";",2),$P(PK,";",3),IFN) I 'TEST Q ""
69 S SPEC=$$SAMP($P(PK,";",2),$P(PK,";",3)) I 'SPEC Q ""
70 S SPEC=$O(^LAB(60,TEST,3,"B",SPEC,0)) I 'SPEC Q ""
71 Q "^LAB(60,"_TEST_",3,"_SPEC_",1)"
72WARDCOM(PK,IFN) ;Get General Ward comments on a test order
73 N TEST
74 S TEST=+$$GETST($P(PK,";",2),$P(PK,";",3),IFN) I 'TEST Q ""
75 Q "^LAB(60,"_TEST_",6)"
76EXPAND(TEST,ARAY) ;Expand a lab test panel
77 ;TEST=Test ptr to file 60
78 ;Expanded panel returned in ARAY(TEST)
79 N INARAY
80 D EX(TEST)
81 M ARAY=INARAY
82 Q
83EX(TST) ;
84 N J,X,SUB
85 Q:'$D(^LAB(60,TST,0)) S SUB=$P(^(0),"^",5)
86 I $L(SUB) S:'$D(INARAY(+TST)) INARAY(+TST)="" Q
87 S J=0 F S J=$O(^LAB(60,+TST,2,J)) Q:J<1 S X=^(J,0) D EX(+X)
88 Q
89SPLIT(TXT,ARAY,CTR,LENGTH,PRE,POST) ;Splits text into an array
90 ;Splits text at nearest space from LENGTH value
91 ;Word limit: 150 characters...<150 stored on own node, >150 split
92 ;TXT- text to be split
93 ;ARAY- array to put the text (e.g. "LOCAL", "^TMP(""LRT"",$J)")
94 ;CTR- starting point in array, default=0. Passed by reference so that external counter is incremented.
95 ;LENGTH- length for each array node, default=80
96 ;PRE- optional text to append at the beginning of each array node
97 ;POST- optional text to append at the end of each array node
98 N END
99 Q:'$L($G(TXT)) Q:'$L($G(ARAY))
100 S:'$G(CTR) CTR=0
101 S:'$G(LENGTH) LENGTH=80
102 S:'$L($G(PRE)) PRE=""
103 S:'$L($G(POST)) POST=""
104 I $L(TXT)'>LENGTH!('$F(TXT," ",LENGTH)),$L(TXT)<150 S CTR=CTR+1,@ARAY@(CTR)=PRE_$$STRIP(TXT)_POST Q
105 S END=$S($F(TXT," ",LENGTH):$F(TXT," ",LENGTH),1:LENGTH)
106 S:END>150 END=150
107 S CTR=CTR+1,@ARAY@(CTR)=PRE_$$STRIP($E(TXT,1,$S(END=LENGTH:END,1:END-1)))_POST
108 D SPLIT($E(TXT,END,999),ARAY,.CTR,LENGTH,PRE,POST)
109 Q
110STRIP(X) ; -- Strip leading spaces from text X
111 N I,Y S Y=""
112 F I=1:1:$L(X) I $E(X,I)'=" " S Y=$E(X,I,999) Q
113 Q Y
Note: See TracBrowser for help on using the repository browser.