- LR7OB630 ;slc/dcm - Get Lab data from 63 only ;8/11/97
- ;;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB630 2876 printed Apr 23, 2025@18:18:46 Page 2
- LR7OB630 ;slc/dcm - Get Lab data from 63 only ;8/11/97
- +1 ;;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
