LA7UTIL ; IHS/DIR/AAB - Utilities for Messenger ;
;;5.2;LA;**1003**;SEP 01, 1998
;
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,42**;Sep 27, 1994
CPT(X) N LA7,LA7CNT,Y
K ^TMP("LA",$J) S LA7CNT=0
F LA7=0:0 S LA7=$O(^LAB(64.4,LA7)) Q:'LA7 D
. I ^LAB(64.4,LA7,0)[X S LA7CNT=LA7CNT+1 S ^TMP("LA",$J,LA7CNT)=LA7
. ;KAT ADDED FULL GLOBAL REFERENCE ^LAB(64.4,LA7,0) VS ^(LA7,0)
I '$O(^TMP("LA",$J,0)) W " ???" K X,LA7,^TMP("LA",$J) QUIT
S X=""
F LA7=0:0 S LA7=$O(^TMP("LA",$J,LA7)) Q:'LA7 D Q:X!(LA7="")
. S LA7(0)=^LAB(64.4,^TMP("LA",$J,LA7),0)
. W !,?5,$J("("_LA7_") ",6),$P(LA7(0),"^"),?22,$TR($P(LA7(0),"^",2,99),"^"," ")
. I (LA7#10=0)!('$O(^TMP("LA",$J,LA7))) D
. . K DIR S DIR(0)="NOA^0:"_LA7,DIR("A")="Select [1-"_LA7_"]: "
. . D ^DIR
. . I X!$D(DUOUT)!$D(DTOUT) S LA7=""
I X S X=$P(^LAB(64.4,^TMP("LA",$J,X),0),"^")
I 'X K X
K DIR,DTOUT,DUOUT,^TMP("LA",$J)
QUIT
;
BU2 N J,S1,T,X
S (J,S1)=0,(T,X)=LA7
D TREE
QUIT
TREE I '$D(^LAB(60,X,0)) Q ;BAD LRTEST NUMBER;
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)
;KAT ADDED FULL GLOBAL REFERENCE ^LAB(60,X,0) VS $P(^(0),U,5)
Q:'$D(^LAB(60,X,2,0)) Q:$O(^(0))<1 ;NOT A PANEL
S S1=S1+1,S1(S1)=X,J1(S1)=J
F J=0:0 S J=$O(^LAB(60,S1(S1),2,J)) Q:J<1 S X=^(J,0) D TREE
S J=J1(S1),X=S1(S1),S1=S1-1
Q
UNWIND(LA760) ;unwind one panel, calls itself recursively to unwind all
;panels within other panels. Returns all atomic tests in ^TMP global.
;Calling routine is responsible for killing ^TMP("LA7TREE" before and
;after the call.
Q:$G(LA7TREEN)>999 ;recursive panel, caught in loop
Q:'$D(^LAB(60,LA760,0))
S ^TMP("LA7TREE",$J,LA760)=""
S LA7TREEN=$G(LA7TREEN)+1
Q:'$D(^LAB(60,LA760,2,0)) Q:$O(^(0))<1
N I,II
F I=0:0 S I=$O(^LAB(60,LA760,2,I)) Q:'I D
. S II=+$G(^LAB(60,LA760,2,I,0)) I II D UNWIND(II)
QUIT
PRETTY(LA76249) ;Store an HL7 message text in pretty print format, stored in
;^TMP("LA7PRETTY",$J,. Required variable is LA76249 = pointer to
;^LAHM(62.49), passed as parameter.
;
K ^TMP("LA7PRETTY",$J)
Q:'$D(^LAHM(62.49,LA76249,0))
Q:'$D(^LAHM(62.49,LA76249,150,1,0))
N LA7,LA7624,LA7FS,LA7INST,X,Y,Z,%
S LA7=$P(^LAHM(62.49,LA76249,0),"^",2)
S LA7FS=$E($G(^LAHM(62.49,LA76249,150,1,0)),4)
S:LA7FS="" ^TMP("LA7PRETTY",$J,2)="<Bad Message Header>"
Q:LA7FS=""
G:LA7="O" PRETOUT
G:LA7="I" PRETIN
QUIT
PRETIN S ^TMP("LA7PRETTY",$J,1)="Result received from "
S LA7INST=$P(^LAHM(62.49,LA76249,0),"^",6)
I LA7INST="" D
. F LA7=0:0 S LA7=$O(^LAHM(62.49,LA76240,150,LA7)) Q:LA7="" D
. . S Z=$G(^LAHM(62.49,LA76249,150,LA7,0))
. . Q:Z=""!($E(Z,1,3)'="OBR")
. . S LA7INST=$P(Z,LA7FS,19)
S ^LAHM(62.49,LA76240,150,1)=^TMP("LA7PRETTY",$J,1)_LA7INST
;KAT ADDED ^LAHM(62.49,LA76240,150,LA7 VS ^(1)
S Y=$P(^LAHM(62.49,LA76249,0),"^",5)
D DD^%DT
S ^LAHM(62.49,LA76249,1)=^TMP("LA7PRETTY",$J,1)_", "_Y
;KAT ADDED ^LAHM(62.49,LA76249 VS ^(1)
S LA7624=$O(^LAB(62.4,"B",LA7INST,0))
F LA7=0:0 S LA7=$O(^LAHM(62.49,LA76249,150,LA7)) Q:LA7="" D
. S X=$G(^LAHM(62.49,LA76249,150,LA7,0))
. Q:(X="")!($E(X,1,3)'="PID") ;find PID segment for SSN
. S Y=+$P(X,LA7FS,4) ;get ssn
. S Z=Y
. S Y=+$O(^DPT("SSN",Y,0)) ;get dfn
. S ^TMP("LA7PRETTY",$J,2)="Patient: "_$P($G(^DPT(Y,0)),"^")_" SSN: "_Z
Q
PRETOUT ;
;
LOG ;Print the error log which is stored in ^XTMP. Errors are logged
;only if the Debug Log field is turned on in 62.48
N LA7,LA76249,LA7DT,LA7TM,LA7TXT,LA7XTMP
D DT^DICRW
S LA7XTMP="LA7"_DT
I '$O(^XTMP(LA7XTMP,0)) W !!,?5,"Nothing logged for Today!"
K DIR
S DIR("A")="Look at log for what date? "
S DIR("B")="TODAY"
S DIR("?")="^D HELP^%DTC"
S DIR(0)="DA^:DT:EX"
D ^DIR
Q:$D(DIRUT)
S LA7XTMP="LA7"_Y
I '$O(^XTMP(LA7XTMP,0)) D G LOG
. W !!,?5,"Nothing logged for " X ^DD("DD") W Y
S LA7TM=""
F S LA7TM=$O(^XTMP(LA7XTMP,LA7TM),-1) Q:LA7TM=0 D Q:LA7QUIT
. S LA7QUIT=0
. I $Y>(IOSL-3) D W @IOF Q:LA7QUIT
. . I "Pp"'[$E(IOST) K DIR S DIR(0)="E" D ^DIR I 'Y S LA7QUIT=1 Q
. S LA7=$E(LA7XTMP,4,10)
. W:$X !! W $E(LA7,4,5),"/",$E(LA7,6,7)
. W "@",$E(LA7TM,1,4)_$E("0000",$L($E(LA7TM,1,4)),3)," "
. W $P(^XTMP(LA7XTMP,LA7TM),"^",2)," " S X=$P($P(^(LA7TM),"^",3),":")
. F LA7=1:1:$L(X," ") S Y=$P(X," ",LA7) W:($L(Y)+$X+1)>IOM ! W " ",Y
Q
;
CADT(LA7AA) ; Calculate current accession date based on accession area transform
; Call with LA7AA = ien of accession area
N LA7AD,X
S DT=$$DT^XLFDT
S X=$P($G(^LRO(68,+$G(LA7AA),0)),"^",3) ; Accession transform
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
Q LA7AD
LA7UTIL ; IHS/DIR/AAB - Utilities for Messenger ;
+1 ;;5.2;LA;**1003**;SEP 01, 1998
+2 ;
+3 ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,42**;Sep 27, 1994
CPT(X) NEW LA7,LA7CNT,Y
+1 KILL ^TMP("LA",$JOB)
SET LA7CNT=0
+2 FOR LA7=0:0
SET LA7=$ORDER(^LAB(64.4,LA7))
IF 'LA7
QUIT
Begin DoDot:1
+3 IF ^LAB(64.4,LA7,0)[X
SET LA7CNT=LA7CNT+1
SET ^TMP("LA",$JOB,LA7CNT)=LA7
+4 ;KAT ADDED FULL GLOBAL REFERENCE ^LAB(64.4,LA7,0) VS ^(LA7,0)
End DoDot:1
+5 IF '$ORDER(^TMP("LA",$JOB,0))
WRITE " ???"
KILL X,LA7,^TMP("LA",$JOB)
QUIT
+6 SET X=""
+7 FOR LA7=0:0
SET LA7=$ORDER(^TMP("LA",$JOB,LA7))
IF 'LA7
QUIT
Begin DoDot:1
+8 SET LA7(0)=^LAB(64.4,^TMP("LA",$JOB,LA7),0)
+9 WRITE !,?5,$JUSTIFY("("_LA7_") ",6),$PIECE(LA7(0),"^"),?22,$TRANSLATE($PIECE(LA7(0),"^",2,99),"^"," ")
+10 IF (LA7#10=0)!('$ORDER(^TMP("LA",$JOB,LA7)))
Begin DoDot:2
+11 KILL DIR
SET DIR(0)="NOA^0:"_LA7
SET DIR("A")="Select [1-"_LA7_"]: "
+12 DO ^DIR
+13 IF X!$DATA(DUOUT)!$DATA(DTOUT)
SET LA7=""
End DoDot:2
End DoDot:1
IF X!(LA7="")
QUIT
+14 IF X
SET X=$PIECE(^LAB(64.4,^TMP("LA",$JOB,X),0),"^")
+15 IF 'X
KILL X
+16 KILL DIR,DTOUT,DUOUT,^TMP("LA",$JOB)
+17 QUIT
+18 ;
BU2 NEW J,S1,T,X
+1 SET (J,S1)=0
SET (T,X)=LA7
+2 DO TREE
+3 QUIT
TREE ;BAD LRTEST NUMBER;
IF '$DATA(^LAB(60,X,0))
QUIT
+1 IF $PIECE(^LAB(60,X,0),U,5)]""
IF $DATA(^TMP("LA7TREE",$JOB,X,X))
SET ^TMP("LA7TREE",$JOB,T,X)=^TMP("LA7TREE",$JOB,X,X)
+2 ;KAT ADDED FULL GLOBAL REFERENCE ^LAB(60,X,0) VS $P(^(0),U,5)
+3 ;NOT A PANEL
IF '$DATA(^LAB(60,X,2,0))
QUIT
IF $ORDER(^(0))<1
QUIT
+4 SET S1=S1+1
SET S1(S1)=X
SET J1(S1)=J
+5 FOR J=0:0
SET J=$ORDER(^LAB(60,S1(S1),2,J))
IF J<1
QUIT
SET X=^(J,0)
DO TREE
+6 SET J=J1(S1)
SET X=S1(S1)
SET S1=S1-1
+7 QUIT
UNWIND(LA760) ;unwind one panel, calls itself recursively to unwind all
+1 ;panels within other panels. Returns all atomic tests in ^TMP global.
+2 ;Calling routine is responsible for killing ^TMP("LA7TREE" before and
+3 ;after the call.
+4 ;recursive panel, caught in loop
IF $GET(LA7TREEN)>999
QUIT
+5 IF '$DATA(^LAB(60,LA760,0))
QUIT
+6 SET ^TMP("LA7TREE",$JOB,LA760)=""
+7 SET LA7TREEN=$GET(LA7TREEN)+1
+8 IF '$DATA(^LAB(60,LA760,2,0))
QUIT
IF $ORDER(^(0))<1
QUIT
+9 NEW I,II
+10 FOR I=0:0
SET I=$ORDER(^LAB(60,LA760,2,I))
IF 'I
QUIT
Begin DoDot:1
+11 SET II=+$GET(^LAB(60,LA760,2,I,0))
IF II
DO UNWIND(II)
End DoDot:1
+12 QUIT
PRETTY(LA76249) ;Store an HL7 message text in pretty print format, stored in
+1 ;^TMP("LA7PRETTY",$J,. Required variable is LA76249 = pointer to
+2 ;^LAHM(62.49), passed as parameter.
+3 ;
+4 KILL ^TMP("LA7PRETTY",$JOB)
+5 IF '$DATA(^LAHM(62.49,LA76249,0))
QUIT
+6 IF '$DATA(^LAHM(62.49,LA76249,150,1,0))
QUIT
+7 NEW LA7,LA7624,LA7FS,LA7INST,X,Y,Z,%
+8 SET LA7=$PIECE(^LAHM(62.49,LA76249,0),"^",2)
+9 SET LA7FS=$EXTRACT($GET(^LAHM(62.49,LA76249,150,1,0)),4)
+10 IF LA7FS=""
SET ^TMP("LA7PRETTY",$JOB,2)="<Bad Message Header>"
+11 IF LA7FS=""
QUIT
+12 IF LA7="O"
GOTO PRETOUT
+13 IF LA7="I"
GOTO PRETIN
+14 QUIT
PRETIN SET ^TMP("LA7PRETTY",$JOB,1)="Result received from "
+1 SET LA7INST=$PIECE(^LAHM(62.49,LA76249,0),"^",6)
+2 IF LA7INST=""
Begin DoDot:1
+3 FOR LA7=0:0
SET LA7=$ORDER(^LAHM(62.49,LA76240,150,LA7))
IF LA7=""
QUIT
Begin DoDot:2
+4 SET Z=$GET(^LAHM(62.49,LA76249,150,LA7,0))
+5 IF Z=""!($EXTRACT(Z,1,3)'="OBR")
QUIT
+6 SET LA7INST=$PIECE(Z,LA7FS,19)
End DoDot:2
End DoDot:1
+7 SET ^LAHM(62.49,LA76240,150,1)=^TMP("LA7PRETTY",$JOB,1)_LA7INST
+8 ;KAT ADDED ^LAHM(62.49,LA76240,150,LA7 VS ^(1)
+9 SET Y=$PIECE(^LAHM(62.49,LA76249,0),"^",5)
+10 DO DD^%DT
+11 SET ^LAHM(62.49,LA76249,1)=^TMP("LA7PRETTY",$JOB,1)_", "_Y
+12 ;KAT ADDED ^LAHM(62.49,LA76249 VS ^(1)
+13 SET LA7624=$ORDER(^LAB(62.4,"B",LA7INST,0))
+14 FOR LA7=0:0
SET LA7=$ORDER(^LAHM(62.49,LA76249,150,LA7))
IF LA7=""
QUIT
Begin DoDot:1
+15 SET X=$GET(^LAHM(62.49,LA76249,150,LA7,0))
+16 ;find PID segment for SSN
IF (X="")!($EXTRACT(X,1,3)'="PID")
QUIT
+17 ;get ssn
SET Y=+$PIECE(X,LA7FS,4)
+18 SET Z=Y
+19 ;get dfn
SET Y=+$ORDER(^DPT("SSN",Y,0))
+20 SET ^TMP("LA7PRETTY",$JOB,2)="Patient: "_$PIECE($GET(^DPT(Y,0)),"^")_" SSN: "_Z
End DoDot:1
+21 QUIT
PRETOUT ;
+1 ;
LOG ;Print the error log which is stored in ^XTMP. Errors are logged
+1 ;only if the Debug Log field is turned on in 62.48
+2 NEW LA7,LA76249,LA7DT,LA7TM,LA7TXT,LA7XTMP
+3 DO DT^DICRW
+4 SET LA7XTMP="LA7"_DT
+5 IF '$ORDER(^XTMP(LA7XTMP,0))
WRITE !!,?5,"Nothing logged for Today!"
+6 KILL DIR
+7 SET DIR("A")="Look at log for what date? "
+8 SET DIR("B")="TODAY"
+9 SET DIR("?")="^D HELP^%DTC"
+10 SET DIR(0)="DA^:DT:EX"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
QUIT
+13 SET LA7XTMP="LA7"_Y
+14 IF '$ORDER(^XTMP(LA7XTMP,0))
Begin DoDot:1
+15 WRITE !!,?5,"Nothing logged for "
XECUTE ^DD("DD")
WRITE Y
End DoDot:1
GOTO LOG
+16 SET LA7TM=""
+17 FOR
SET LA7TM=$ORDER(^XTMP(LA7XTMP,LA7TM),-1)
IF LA7TM=0
QUIT
Begin DoDot:1
+18 SET LA7QUIT=0
+19 IF $Y>(IOSL-3)
Begin DoDot:2
+20 IF "Pp"'[$EXTRACT(IOST)
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET LA7QUIT=1
QUIT
End DoDot:2
WRITE @IOF
IF LA7QUIT
QUIT
+21 SET LA7=$EXTRACT(LA7XTMP,4,10)
+22 IF $X
WRITE !!
WRITE $EXTRACT(LA7,4,5),"/",$EXTRACT(LA7,6,7)
+23 WRITE "@",$EXTRACT(LA7TM,1,4)_$EXTRACT("0000",$LENGTH($EXTRACT(LA7TM,1,4)),3)," "
+24 WRITE $PIECE(^XTMP(LA7XTMP,LA7TM),"^",2)," "
SET X=$PIECE($PIECE(^(LA7TM),"^",3),":")
+25 FOR LA7=1:1:$LENGTH(X," ")
SET Y=$PIECE(X," ",LA7)
IF ($LENGTH(Y)+$X+1)>IOM
WRITE !
WRITE " ",Y
End DoDot:1
IF LA7QUIT
QUIT
+26 QUIT
+27 ;
CADT(LA7AA) ; Calculate current accession date based on accession area transform
+1 ; Call with LA7AA = ien of accession area
+2 NEW LA7AD,X
+3 SET DT=$$DT^XLFDT
+4 ; Accession transform
SET X=$PIECE($GET(^LRO(68,+$GET(LA7AA),0)),"^",3)
+5 ; Calculate date
SET LA7AD=$SELECT(X="D":DT,X="M":$EXTRACT(DT,1,5)_"00",X="Y":$EXTRACT(DT,1,3)_"0000",X="Q":$EXTRACT(DT,1,3)_"0000"+(($EXTRACT(DT,4,5)-1)\3*300+100),1:DT)
+6 QUIT LA7AD
