LR7OB630 ; IHS/DIR/AAB - Get Lab data from 63 only ; [ 8/11/97 ]
;;5.2;LR;**1003**;JUN 01, 1998
;
;;5.2;LAB SERVICE;**121**;Sep 27, 1994
EN(LABPAT,SS,IDT) ;Get data from 63
;LABPAT=Lab Patient ID
;SS=Subscript CH, MI, EM, CY, AU, SP, BB
;IDT=Inverse D/T verified
Q:'$G(LABPAT)!('$G(IDT))!('$L($G(SS)))
N GOTCOM
I $L($T(@SS)) G @SS
Q
CH ;Chem, Hem, Tox, Ria, Ser, etc.
N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
D DFN
S (AC,Y1,Y3,Y4,Y11)="",Y2=+X0,Y5=+X0,Y6="",Y7=$P(X0,"^",11),Y8=+X0,Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
I AC D 68 Q
D 69,63^LR7OB63(1,LRDFN,SS,IDT)
Q
MI ;Microbiology
N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
D DFN
S (AC,Y1,Y4,Y5,Y11)="",Y2=+X0,Y3=$P(X0,"^",11),Y6=$P(X0,"^",7),Y7=$P(X0,"^",8),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
I AC D 68 Q
D 69,63^LR7OB63(1,LRDFN,SS,IDT)
Q
BB ;Blood bank
N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
D DFN
S (AC,Y1,Y4,Y5,Y11)="",Y2=+X0,Y3=$P(X0,"^",11),Y6=$P(X0,"^",7),Y7=$P(X0,"^",4),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y10=$P(X0,"^",5),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
I AC D 68 Q
D 69,63^LR7OB63(1,LRDFN,SS,IDT)
Q
EM ;Electron Microscopy
G CY
SP ;Surgical Pathology
G CY
CY ;Cytology
N Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
Q:'$D(^LR(LABPAT,SS,IDT)) S X0=^(IDT,0)
D DFN
S (AC,Y1,Y3,Y4,Y5,Y10,Y11)="",Y2=+X0,Y6=$P(X0,"^",7),Y7=$P(X0,"^",8),Y8=$P(X0,"^",10),Y9=$P(X0,"^",3),Y12=$P(X0,"^",4),ACC=$P(X0,"^",6)
I $L(ACC) S X=$P(ACC," "),X=$O(^LRO(68,"B",X,0)) I X S AC=X,ACD=+$P(X0,"."),ACN=$P(ACC," ",3) S:'$D(^LRO(68,AC,1,ACD,1,ACN)) AC=""
I AC D 68 Q
D 69,63^LR7OB63(1,LRDFN,SS,IDT)
Q
AU ;Autopsy
N X,X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12
Q:'$D(^LR(LABPAT,SS)) S X0=^(SS)
D DFN
S (Y1,Y3,Y4,Y5,Y8,Y10,Y11,Y12)="",Y2=+X0,Y6=$P(X0,"^",12),Y7=$P(X0,"^",5),Y9=$P(X0,"^",3)
D 69,63^LR7OB63(1,LRDFN,SS)
Q
DFN ;Get patient stuff
S:'$D(DFN) DFN=$P(^LR(LABPAT,0),"^",3) S:'$D(LRDFN) LRDFN=LABPAT S:'$D(LRDPF) LRDPF=$P(^LR(LABPAT,0),"^",2)_$G(^DIC(+$P(^LR(LABPAT,0),"^",2),0,"GL"))
Q
69 ;Set lrx(69
S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12,^TMP("LRX",$J,69,1)=""
Q
68 ;Go get data from file 68
D A68^LR7OB68(ACD,AC,ACN)
Q
LR7OB630 ; IHS/DIR/AAB - Get Lab data from 63 only ; [ 8/11/97 ]
+1 ;;5.2;LR;**1003**;JUN 01, 1998
+2 ;
+3 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
EN(LABPAT,SS,IDT) ;Get data from 63
+1 ;LABPAT=Lab Patient ID
+2 ;SS=Subscript CH, MI, EM, CY, AU, SP, BB
+3 ;IDT=Inverse D/T verified
+4 IF '$GET(LABPAT)!('$GET(IDT))!('$LENGTH($GET(SS)))
QUIT
+5 NEW GOTCOM
+6 IF $LENGTH($TEXT(@SS))
GOTO @SS
+7 QUIT
CH ;Chem, Hem, Tox, Ria, Ser, etc.
+1 NEW Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
+2 IF '$DATA(^LR(LABPAT,SS,IDT))
QUIT
SET X0=^(IDT,0)
+3 DO DFN
+4 SET (AC,Y1,Y3,Y4,Y11)=""
SET Y2=+X0
SET Y5=+X0
SET Y6=""
SET Y7=$PIECE(X0,"^",11)
SET Y8=+X0
SET Y9=$PIECE(X0,"^",3)
SET Y10=$PIECE(X0,"^",5)
SET Y12=$PIECE(X0,"^",4)
SET ACC=$PIECE(X0,"^",6)
+5 IF $LENGTH(ACC)
SET X=$PIECE(ACC," ")
SET X=$ORDER(^LRO(68,"B",X,0))
IF X
SET AC=X
SET ACD=+$PIECE(X0,".")
SET ACN=$PIECE(ACC," ",3)
IF '$DATA(^LRO(68,AC,1,ACD,1,ACN))
SET AC=""
+6 IF AC
DO 68
QUIT
+7 DO 69
DO 63^LR7OB63(1,LRDFN,SS,IDT)
+8 QUIT
MI ;Microbiology
+1 NEW Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
+2 IF '$DATA(^LR(LABPAT,SS,IDT))
QUIT
SET X0=^(IDT,0)
+3 DO DFN
+4 SET (AC,Y1,Y4,Y5,Y11)=""
SET Y2=+X0
SET Y3=$PIECE(X0,"^",11)
SET Y6=$PIECE(X0,"^",7)
SET Y7=$PIECE(X0,"^",8)
SET Y8=$PIECE(X0,"^",10)
SET Y9=$PIECE(X0,"^",3)
SET Y10=$PIECE(X0,"^",5)
SET Y12=$PIECE(X0,"^",4)
SET ACC=$PIECE(X0,"^",6)
+5 IF $LENGTH(ACC)
SET X=$PIECE(ACC," ")
SET X=$ORDER(^LRO(68,"B",X,0))
IF X
SET AC=X
SET ACD=+$PIECE(X0,".")
SET ACN=$PIECE(ACC," ",3)
IF '$DATA(^LRO(68,AC,1,ACD,1,ACN))
SET AC=""
+6 IF AC
DO 68
QUIT
+7 DO 69
DO 63^LR7OB63(1,LRDFN,SS,IDT)
+8 QUIT
BB ;Blood bank
+1 NEW Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
+2 IF '$DATA(^LR(LABPAT,SS,IDT))
QUIT
SET X0=^(IDT,0)
+3 DO DFN
+4 SET (AC,Y1,Y4,Y5,Y11)=""
SET Y2=+X0
SET Y3=$PIECE(X0,"^",11)
SET Y6=$PIECE(X0,"^",7)
SET Y7=$PIECE(X0,"^",4)
SET Y8=$PIECE(X0,"^",10)
SET Y9=$PIECE(X0,"^",3)
SET Y10=$PIECE(X0,"^",5)
SET Y12=$PIECE(X0,"^",4)
SET ACC=$PIECE(X0,"^",6)
+5 IF $LENGTH(ACC)
SET X=$PIECE(ACC," ")
SET X=$ORDER(^LRO(68,"B",X,0))
IF X
SET AC=X
SET ACD=+$PIECE(X0,".")
SET ACN=$PIECE(ACC," ",3)
IF '$DATA(^LRO(68,AC,1,ACD,1,ACN))
SET AC=""
+6 IF AC
DO 68
QUIT
+7 DO 69
DO 63^LR7OB63(1,LRDFN,SS,IDT)
+8 QUIT
EM ;Electron Microscopy
+1 GOTO CY
SP ;Surgical Pathology
+1 GOTO CY
CY ;Cytology
+1 NEW Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,ACC,AC,ACD,ACN,X,X0
+2 IF '$DATA(^LR(LABPAT,SS,IDT))
QUIT
SET X0=^(IDT,0)
+3 DO DFN
+4 SET (AC,Y1,Y3,Y4,Y5,Y10,Y11)=""
SET Y2=+X0
SET Y6=$PIECE(X0,"^",7)
SET Y7=$PIECE(X0,"^",8)
SET Y8=$PIECE(X0,"^",10)
SET Y9=$PIECE(X0,"^",3)
SET Y12=$PIECE(X0,"^",4)
SET ACC=$PIECE(X0,"^",6)
+5 IF $LENGTH(ACC)
SET X=$PIECE(ACC," ")
SET X=$ORDER(^LRO(68,"B",X,0))
IF X
SET AC=X
SET ACD=+$PIECE(X0,".")
SET ACN=$PIECE(ACC," ",3)
IF '$DATA(^LRO(68,AC,1,ACD,1,ACN))
SET AC=""
+6 IF AC
DO 68
QUIT
+7 DO 69
DO 63^LR7OB63(1,LRDFN,SS,IDT)
+8 QUIT
AU ;Autopsy
+1 NEW X,X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12
+2 IF '$DATA(^LR(LABPAT,SS))
QUIT
SET X0=^(SS)
+3 DO DFN
+4 SET (Y1,Y3,Y4,Y5,Y8,Y10,Y11,Y12)=""
SET Y2=+X0
SET Y6=$PIECE(X0,"^",12)
SET Y7=$PIECE(X0,"^",5)
SET Y9=$PIECE(X0,"^",3)
+5 DO 69
DO 63^LR7OB63(1,LRDFN,SS)
+6 QUIT
DFN ;Get patient stuff
+1 IF '$DATA(DFN)
SET DFN=$PIECE(^LR(LABPAT,0),"^",3)
IF '$DATA(LRDFN)
SET LRDFN=LABPAT
IF '$DATA(LRDPF)
SET LRDPF=$PIECE(^LR(LABPAT,0),"^",2)_$GET(^DIC(+$PIECE(^LR(LABPAT,0),"^",2),0,"GL"))
+2 QUIT
69 ;Set lrx(69
+1 SET ^TMP("LRX",$JOB,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
SET ^TMP("LRX",$JOB,69,1)=""
+2 QUIT
68 ;Go get data from file 68
+1 DO A68^LR7OB68(ACD,AC,ACN)
+2 QUIT
