source: FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UTIL.m@ 1806

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1LA7UTIL ;DALISC/JRR - Utilities for Messenger
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,42**;Sep 27, 1994
3CPT(X) N LA7,LA7CNT,Y
4 K ^TMP("LA",$J) S LA7CNT=0
5 F LA7=0:0 S LA7=$O(^LAB(64.4,LA7)) Q:'LA7 D
6 . I ^LAB(64.4,LA7,0)[X S LA7CNT=LA7CNT+1 S ^TMP("LA",$J,LA7CNT)=LA7
7 . ;KAT ADDED FULL GLOBAL REFERENCE ^LAB(64.4,LA7,0) VS ^(LA7,0)
8 I '$O(^TMP("LA",$J,0)) W " ???" K X,LA7,^TMP("LA",$J) QUIT
9 S X=""
10 F LA7=0:0 S LA7=$O(^TMP("LA",$J,LA7)) Q:'LA7 D Q:X!(LA7="")
11 . S LA7(0)=^LAB(64.4,^TMP("LA",$J,LA7),0)
12 . W !,?5,$J("("_LA7_") ",6),$P(LA7(0),"^"),?22,$TR($P(LA7(0),"^",2,99),"^"," ")
13 . I (LA7#10=0)!('$O(^TMP("LA",$J,LA7))) D
14 . . K DIR S DIR(0)="NOA^0:"_LA7,DIR("A")="Select [1-"_LA7_"]: "
15 . . D ^DIR
16 . . I X!$D(DUOUT)!$D(DTOUT) S LA7=""
17 I X S X=$P(^LAB(64.4,^TMP("LA",$J,X),0),"^")
18 I 'X K X
19 K DIR,DTOUT,DUOUT,^TMP("LA",$J)
20 QUIT
21 ;
22BU2 N J,S1,T,X
23 S (J,S1)=0,(T,X)=LA7
24 D TREE
25 QUIT
26TREE I '$D(^LAB(60,X,0)) Q ;BAD LRTEST NUMBER;
27 I $P(^LAB(60,X,0),U,5)]"",$D(^TMP("LA7TREE",$J,X,X)) S ^TMP("LA7TREE",$J,T,X)=^TMP("LA7TREE",$J,X,X)
28 ;KAT ADDED FULL GLOBAL REFERENCE ^LAB(60,X,0) VS $P(^(0),U,5)
29 Q:'$D(^LAB(60,X,2,0)) Q:$O(^(0))<1 ;NOT A PANEL
30 S S1=S1+1,S1(S1)=X,J1(S1)=J
31 F J=0:0 S J=$O(^LAB(60,S1(S1),2,J)) Q:J<1 S X=^(J,0) D TREE
32 S J=J1(S1),X=S1(S1),S1=S1-1
33 Q
34UNWIND(LA760) ;unwind one panel, calls itself recursively to unwind all
35 ;panels within other panels. Returns all atomic tests in ^TMP global.
36 ;Calling routine is responsible for killing ^TMP("LA7TREE" before and
37 ;after the call.
38 Q:$G(LA7TREEN)>999 ;recursive panel, caught in loop
39 Q:'$D(^LAB(60,LA760,0))
40 S ^TMP("LA7TREE",$J,LA760)=""
41 S LA7TREEN=$G(LA7TREEN)+1
42 Q:'$D(^LAB(60,LA760,2,0)) Q:$O(^(0))<1
43 N I,II
44 F I=0:0 S I=$O(^LAB(60,LA760,2,I)) Q:'I D
45 . S II=+$G(^LAB(60,LA760,2,I,0)) I II D UNWIND(II)
46 QUIT
47PRETTY(LA76249) ;Store an HL7 message text in pretty print format, stored in
48 ;^TMP("LA7PRETTY",$J,. Required variable is LA76249 = pointer to
49 ;^LAHM(62.49), passed as parameter.
50 ;
51 K ^TMP("LA7PRETTY",$J)
52 Q:'$D(^LAHM(62.49,LA76249,0))
53 Q:'$D(^LAHM(62.49,LA76249,150,1,0))
54 N LA7,LA7624,LA7FS,LA7INST,X,Y,Z,%
55 S LA7=$P(^LAHM(62.49,LA76249,0),"^",2)
56 S LA7FS=$E($G(^LAHM(62.49,LA76249,150,1,0)),4)
57 S:LA7FS="" ^TMP("LA7PRETTY",$J,2)="<Bad Message Header>"
58 Q:LA7FS=""
59 G:LA7="O" PRETOUT
60 G:LA7="I" PRETIN
61 QUIT
62PRETIN S ^TMP("LA7PRETTY",$J,1)="Result received from "
63 S LA7INST=$P(^LAHM(62.49,LA76249,0),"^",6)
64 I LA7INST="" D
65 . F LA7=0:0 S LA7=$O(^LAHM(62.49,LA76240,150,LA7)) Q:LA7="" D
66 . . S Z=$G(^LAHM(62.49,LA76249,150,LA7,0))
67 . . Q:Z=""!($E(Z,1,3)'="OBR")
68 . . S LA7INST=$P(Z,LA7FS,19)
69 S ^LAHM(62.49,LA76240,150,1)=^TMP("LA7PRETTY",$J,1)_LA7INST
70 ;KAT ADDED ^LAHM(62.49,LA76240,150,LA7 VS ^(1)
71 S Y=$P(^LAHM(62.49,LA76249,0),"^",5)
72 D DD^%DT
73 S ^LAHM(62.49,LA76249,1)=^TMP("LA7PRETTY",$J,1)_", "_Y
74 ;KAT ADDED ^LAHM(62.49,LA76249 VS ^(1)
75 S LA7624=$O(^LAB(62.4,"B",LA7INST,0))
76 F LA7=0:0 S LA7=$O(^LAHM(62.49,LA76249,150,LA7)) Q:LA7="" D
77 . S X=$G(^LAHM(62.49,LA76249,150,LA7,0))
78 . Q:(X="")!($E(X,1,3)'="PID") ;find PID segment for SSN
79 . S Y=+$P(X,LA7FS,4) ;get ssn
80 . S Z=Y
81 . S Y=+$O(^DPT("SSN",Y,0)) ;get dfn
82 . S ^TMP("LA7PRETTY",$J,2)="Patient: "_$P($G(^DPT(Y,0)),"^")_" SSN: "_Z
83 Q
84PRETOUT ;
85 ;
86LOG ;Print the error log which is stored in ^XTMP. Errors are logged
87 ;only if the Debug Log field is turned on in 62.48
88 N LA7,LA76249,LA7DT,LA7TM,LA7TXT,LA7XTMP
89 D DT^DICRW
90 S LA7XTMP="LA7"_DT
91 I '$O(^XTMP(LA7XTMP,0)) W !!,?5,"Nothing logged for Today!"
92 K DIR
93 S DIR("A")="Look at log for what date? "
94 S DIR("B")="TODAY"
95 S DIR("?")="^D HELP^%DTC"
96 S DIR(0)="DA^:DT:EX"
97 D ^DIR
98 Q:$D(DIRUT)
99 S LA7XTMP="LA7"_Y
100 I '$O(^XTMP(LA7XTMP,0)) D G LOG
101 . W !!,?5,"Nothing logged for " X ^DD("DD") W Y
102 S LA7TM=""
103 F S LA7TM=$O(^XTMP(LA7XTMP,LA7TM),-1) Q:LA7TM=0 D Q:LA7QUIT
104 . S LA7QUIT=0
105 . I $Y>(IOSL-3) D W @IOF Q:LA7QUIT
106 . . I "Pp"'[$E(IOST) K DIR S DIR(0)="E" D ^DIR I 'Y S LA7QUIT=1 Q
107 . S LA7=$E(LA7XTMP,4,10)
108 . W:$X !! W $E(LA7,4,5),"/",$E(LA7,6,7)
109 . W "@",$E(LA7TM,1,4)_$E("0000",$L($E(LA7TM,1,4)),3)," "
110 . W $P(^XTMP(LA7XTMP,LA7TM),"^",2)," " S X=$P($P(^(LA7TM),"^",3),":")
111 . F LA7=1:1:$L(X," ") S Y=$P(X," ",LA7) W:($L(Y)+$X+1)>IOM ! W " ",Y
112 Q
113 ;
114CADT(LA7AA) ; Calculate current accession date based on accession area transform
115 ; Call with LA7AA = ien of accession area
116 N LA7AD,X
117 S DT=$$DT^XLFDT
118 S X=$P($G(^LRO(68,+$G(LA7AA),0)),"^",3) ; Accession transform
119 S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT) ; Calculate date
120 Q LA7AD
Note: See TracBrowser for help on using the repository browser.