LR7OB63 ; VA/DALOI/dcm - Get Lab data from 63 ; 13-Aug-2013 09:15 ; MKK
;;5.2;LAB SERVICE;**121,1003,1013,187,1018,372,286,1027,406,1033**;NOV 01, 1997
;
63(CTR,LRDFN,SS,IVDT,CORRECT) ;Get data from file 63
;CTR=Counter
;LRDFN=Patient ID
;SS=Subscript for results 'CH'-Chem Tox 'MI'-Microbiology, etc.
;IVDT=Inverse D/T verified
;CORRECT=1 if a corrected result, 0 if not
;See ^LR7OB69 for description of LRX array
I $G(CONTROL)="ZC" Q
N IFN
I $L(SS),$L($T(@SS)) G @SS
Q
;
;
CH ;Chem, Hem, Tox, Ria, Ser, etc.
N LRX,X0,Y1,Y2,Y3,Y4,Y5,Y6,Y12,Y14,Y15,Y16,Y17,Y18
Q:'$D(^LR(LRDFN,"CH",+$G(IVDT),0)) S X0=^(0)
S Y6=$S(+$G(CORRECT):"C",$P(X0,"^",3):"F",1:"")
S Y16=$P(X0,"^",6)
S Y17=$$ORD^LR7OR2(LRDFN,IVDT),Y18=";CH;"_IVDT
;
I '$D(SEX) N SEX S SEX=$P($G(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")),"^",2)
;
I '$D(DOB)!'$D(AGE) N AGE,DOB D
. S DOB=$P($G(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")),"^",3)
. S AGE=$S($D(DT)&(DOB?7N):DT-DOB\10000,1:"??")
;
S IFN=1
; F S IFN=$O(^LR(LRDFN,"CH",IVDT,IFN)) Q:IFN<1 S X=^(IFN) I $D(TSTY(IFN))!($D(BYPASS)),$S('$D(LRSB):1,$D(LRSB(IFN)):1,1:0) D
F S IFN=$O(^LR(LRDFN,"CH",IVDT,IFN)) Q:IFN<1 S X=$G(^(IFN)) I $D(TSTY(IFN))!($D(BYPASS)),$S('$D(LRSB):1,$D(LRSB(IFN)):1,1:0) D ; Naked Reference fix - IHS/MSC/MKK - LR*5.2*1032
. I $D(LRSB(IFN)),$D(LRSA(IFN)),'$D(LRSA(IFN,2)),'$D(LRSA(IFN,3)) Q ;Only re-transmit changed results
. S Y1=IFN,Y1=$O(^LAB(60,"C","CH;"_Y1_";1",0)),Y2=$P(X,"^"),Y3=$P(X,"^",2),Y12=$P(X,"^",4)
. S:Y2="pending" Y6="P" ;Set result status to P for pending results
. Q:"IN"[$P(^LAB(60,Y1,0),"^",3) S Y15=$P($G(^LAB(60,Y1,.1)),"^")
. S (Y9,Y10,Y11,Y14)=""
. I $P($G(^LAB(60,Y1,64)),"^") S Y9=$P(^(64),"^"),Y9=$P(^LAM(Y9,0),"^",2),Y10=$P(^(0),"^"),Y11="99NLT"
. ;D UNIT(Y1,$P(X0,"^",5),SEX,DOB,AGE)
. S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IVDT,IFN,Y1)
. S Y2=$P(LRX,"^"),Y3=$P(LRX,"^",2),Y4=$P(LRX,"^",5),Y5=$$EN^LRLRRVF($P(LRX,"^",3),$P(LRX,"^",4))
. I $P(LRX,"^",7) S Y14="T"
. S Y2=$$TRIM^XLFSTR($$RESULT(Y1,Y2),"LR"," ")
. S ^TMP("LRX",$J,69,CTR,63,IFN)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^^^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12_"^^"_Y14_"^"_Y15_"^"_Y16_"^"_Y17_"^"_Y18
;
I $D(GOTCOM(LRDFN,"CH",IVDT)) Q
S GOTCOM(LRDFN,"CH",IVDT)="",IFN=0
F S IFN=$O(^LR(LRDFN,"CH",IVDT,1,IFN)) Q:IFN<1 S ^TMP("LRX",$J,69,CTR,63,"N",IFN)=$P(^LR(LRDFN,"CH",IVDT,1,IFN,0),"^")
;
Q
;
;
MI ;Microbiology
D MI^LR7OB63A()
Q
;
;
BB ;Blood bank
D BB1()
Q
;
;
BB1(SPECMEN) ;Blood bank
;SPECMEN=ptr to 61, to specify specimen (optional)
N X0,Y1,Y2,Y3,Y4,Y5,Y6,Y15,Y18,Y19,CTR1
Q:'$D(^LR(LRDFN,"BB",+$G(IVDT),0)) S X0=^(0),Y6=$S(+$G(CORRECT):"C",$P(X0,"^",3):"F",1:""),Y19=$P(X0,"^",5),CTR1=0,Y18=";BB;"_IVDT
;There are other multiples for blood bank in file 63 that also need to be processed, this is just a start.
I $G(SPECMEN),Y19'=SPECMEN Q
S IFN=1 F S IFN=$O(^LR(LRDFN,"BB",IVDT,IFN)) Q:IFN<1 I $D(^(IFN))#2 S XNODE=^(IFN) F IFN1=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN1) I $L(X1) D
. S X=$$NODEPIK(63.01,IFN,IFN1,X1) ;X=field^data
. I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18_"^"_Y19
I $D(^LR(LRDFN,"BB",IVDT,99)) S Y1="Specimen Comment: " S IFN=0 F S IFN=$O(^LR(LRDFN,"BB",IVDT,99,IFN)) Q:IFN<1 S Y2=^(IFN,0),^TMP("LRX",$J,69,CTR,63,"N",IFN)=Y1_"^"_Y2
Q
;
;
EM ;Electron Microscopy
D SS^LR7OB63C("EM")
Q
;
;
SP ;Surgical Pathology
D SS^LR7OB63C("SP")
Q
;
;
CY ;Cytology
D SS^LR7OB63C("CY")
Q
;
;
AU ;Autopsy
D AU^LR7OB63D
Q
;
;
NODEPIK(FILE,NODE,PIECE,DATA) ;Set field name and data into X
N Z,Y,Y1,Y2
S Z=$O(^DD(FILE,"GL",NODE,PIECE,0)),X=""
I Z S Y=^DD(FILE,Z,0),Y1=$P(Y,"^"),Y2=DATA S:$P(Y,"^",2)["S" Y2=$$SET(FILE,Z,Y2) S:$P(Y,"^",2)["P"!($P(Y,"^",2)["V") Y2=$$POINTER(FILE,Z,Y2) S X=Y1_"^"_Y2
Q X
;
;
UNIT(X,SPEC,SEX,DOB,AGE) ;Find units and ref range
;X=Result
;SPEC=Specimen ptr
;SEX=Patient sex
;DOB=Patient Date of birth
;AGE=Patient age
;Output: Y4=Units, Y5=Ref Range, Y14=T or "" (If T, range is theraputic)
N LO,HI
S (Y4,Y5,Y14)=""
Q:'$D(^LAB(60,+X,1,+SPEC,0)) S X=^(0) ;No units/ranges defined
S Y4=$P(X,"^",7)
S @("LO="_$S($L($P(X,"^",2)):$P(X,"^",2),$L($P(X,"^",11)):$P(X,"^",11),1:""""""))
S @("HI="_$S($L($P(X,"^",3)):$P(X,"^",3),$L($P(X,"^",12)):$P(X,"^",12),1:""""""))
S Y5=$S($L(HI):LO_"-"_HI,1:LO)
S Y14=$S('$L($P(X,"^",2))&$L($P(X,"^",11)):"T",1:"")
Q
;
;
RESULT(TEST,RESULT) ;Convert result to external format
;TEST=Test ptr to file 60
;RESULT=Test result
N X,X1,LRCW
S LRCW="",X1=$P($G(^LAB(60,TEST,.1)),"^",3),X1=$S($L(X1):X1,1:"$J(X,8)"),X=RESULT,@("X="_X1)
Q X
;
;
STRIP(TEXT) ;Strips white space from text
N I,X
S X="" F I=1:1:$L(TEXT," ") S:$A($P(TEXT," ",I))>0 X=X_$P(TEXT," ",I)
Q X
;
;
SET(FILE,FIELD,RESULT) ;Interpret set of codes
S X=$P(^DD(FILE,FIELD,0),"^",3),X=$P($P(";"_X,";"_RESULT_":",2),";")
Q X
;
;
POINTER(FILE,FIELD,RESULT) ;Interpret pointer values
N X
S X=$P(^DD(FILE,FIELD,0),"^",2)
I X["V" S X1=@("^"_$P(RESULT,";",2)_+RESULT_",0)")
I X'["V" S X1=$P(@("^"_$P(^DD(FILE,FIELD,0),"^",3)_RESULT_",0)"),"^")
Q X1
LR7OB63 ; VA/DALOI/dcm - Get Lab data from 63 ; 13-Aug-2013 09:15 ; MKK
+1 ;;5.2;LAB SERVICE;**121,1003,1013,187,1018,372,286,1027,406,1033**;NOV 01, 1997
+2 ;
63(CTR,LRDFN,SS,IVDT,CORRECT) ;Get data from file 63
+1 ;CTR=Counter
+2 ;LRDFN=Patient ID
+3 ;SS=Subscript for results 'CH'-Chem Tox 'MI'-Microbiology, etc.
+4 ;IVDT=Inverse D/T verified
+5 ;CORRECT=1 if a corrected result, 0 if not
+6 ;See ^LR7OB69 for description of LRX array
+7 IF $GET(CONTROL)="ZC"
QUIT
+8 NEW IFN
+9 IF $LENGTH(SS)
IF $LENGTH($TEXT(@SS))
GOTO @SS
+10 QUIT
+11 ;
+12 ;
CH ;Chem, Hem, Tox, Ria, Ser, etc.
+1 NEW LRX,X0,Y1,Y2,Y3,Y4,Y5,Y6,Y12,Y14,Y15,Y16,Y17,Y18
+2 IF '$DATA(^LR(LRDFN,"CH",+$GET(IVDT),0))
QUIT
SET X0=^(0)
+3 SET Y6=$SELECT(+$GET(CORRECT):"C",$PIECE(X0,"^",3):"F",1:"")
+4 SET Y16=$PIECE(X0,"^",6)
+5 SET Y17=$$ORD^LR7OR2(LRDFN,IVDT)
SET Y18=";CH;"_IVDT
+6 ;
+7 IF '$DATA(SEX)
NEW SEX
SET SEX=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",2)
+8 ;
+9 IF '$DATA(DOB)!'$DATA(AGE)
NEW AGE,DOB
Begin DoDot:1
+10 SET DOB=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",3)
+11 SET AGE=$SELECT($DATA(DT)&(DOB?7N):DT-DOB\10000,1:"??")
End DoDot:1
+12 ;
+13 SET IFN=1
+14 ; F S IFN=$O(^LR(LRDFN,"CH",IVDT,IFN)) Q:IFN<1 S X=^(IFN) I $D(TSTY(IFN))!($D(BYPASS)),$S('$D(LRSB):1,$D(LRSB(IFN)):1,1:0) D
+15 ; Naked Reference fix - IHS/MSC/MKK - LR*5.2*1032
FOR
SET IFN=$ORDER(^LR(LRDFN,"CH",IVDT,IFN))
IF IFN<1
QUIT
SET X=$GET(^(IFN))
IF $DATA(TSTY(IFN))!($DATA(BYPASS))
IF $SELECT('$DATA(LRSB):1,$DATA(LRSB(IFN)):1,1:0)
Begin DoDot:1
+16 ;Only re-transmit changed results
IF $DATA(LRSB(IFN))
IF $DATA(LRSA(IFN))
IF '$DATA(LRSA(IFN,2))
IF '$DATA(LRSA(IFN,3))
QUIT
+17 SET Y1=IFN
SET Y1=$ORDER(^LAB(60,"C","CH;"_Y1_";1",0))
SET Y2=$PIECE(X,"^")
SET Y3=$PIECE(X,"^",2)
SET Y12=$PIECE(X,"^",4)
+18 ;Set result status to P for pending results
IF Y2="pending"
SET Y6="P"
+19 IF "IN"[$PIECE(^LAB(60,Y1,0),"^",3)
QUIT
SET Y15=$PIECE($GET(^LAB(60,Y1,.1)),"^")
+20 SET (Y9,Y10,Y11,Y14)=""
+21 IF $PIECE($GET(^LAB(60,Y1,64)),"^")
SET Y9=$PIECE(^(64),"^")
SET Y9=$PIECE(^LAM(Y9,0),"^",2)
SET Y10=$PIECE(^(0),"^")
SET Y11="99NLT"
+22 ;D UNIT(Y1,$P(X0,"^",5),SEX,DOB,AGE)
+23 SET LRX=$$TSTRES^LRRPU(LRDFN,"CH",IVDT,IFN,Y1)
+24 SET Y2=$PIECE(LRX,"^")
SET Y3=$PIECE(LRX,"^",2)
SET Y4=$PIECE(LRX,"^",5)
SET Y5=$$EN^LRLRRVF($PIECE(LRX,"^",3),$PIECE(LRX,"^",4))
+25 IF $PIECE(LRX,"^",7)
SET Y14="T"
+26 SET Y2=$$TRIM^XLFSTR($$RESULT(Y1,Y2),"LR"," ")
+27 SET ^TMP("LRX",$JOB,69,CTR,63,IFN)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^^^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12_"^^"_Y14_"^"_Y15_"^"_Y16_"^"_Y17_"^"_Y18
End DoDot:1
+28 ;
+29 IF $DATA(GOTCOM(LRDFN,"CH",IVDT))
QUIT
+30 SET GOTCOM(LRDFN,"CH",IVDT)=""
SET IFN=0
+31 FOR
SET IFN=$ORDER(^LR(LRDFN,"CH",IVDT,1,IFN))
IF IFN<1
QUIT
SET ^TMP("LRX",$JOB,69,CTR,63,"N",IFN)=$PIECE(^LR(LRDFN,"CH",IVDT,1,IFN,0),"^")
+32 ;
+33 QUIT
+34 ;
+35 ;
MI ;Microbiology
+1 DO MI^LR7OB63A()
+2 QUIT
+3 ;
+4 ;
BB ;Blood bank
+1 DO BB1()
+2 QUIT
+3 ;
+4 ;
BB1(SPECMEN) ;Blood bank
+1 ;SPECMEN=ptr to 61, to specify specimen (optional)
+2 NEW X0,Y1,Y2,Y3,Y4,Y5,Y6,Y15,Y18,Y19,CTR1
+3 IF '$DATA(^LR(LRDFN,"BB",+$GET(IVDT),0))
QUIT
SET X0=^(0)
SET Y6=$SELECT(+$GET(CORRECT):"C",$PIECE(X0,"^",3):"F",1:"")
SET Y19=$PIECE(X0,"^",5)
SET CTR1=0
SET Y18=";BB;"_IVDT
+4 ;There are other multiples for blood bank in file 63 that also need to be processed, this is just a start.
+5 IF $GET(SPECMEN)
IF Y19'=SPECMEN
QUIT
+6 SET IFN=1
FOR
SET IFN=$ORDER(^LR(LRDFN,"BB",IVDT,IFN))
IF IFN<1
QUIT
IF $DATA(^(IFN))#2
SET XNODE=^(IFN)
FOR IFN1=1:1:$LENGTH(XNODE,"^")
SET X1=$PIECE(XNODE,"^",IFN1)
IF $LENGTH(X1)
Begin DoDot:1
+7 ;X=field^data
SET X=$$NODEPIK(63.01,IFN,IFN1,X1)
+8 IF $LENGTH($PIECE(X,"^"))
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18_"^"_Y19
End DoDot:1
+9 IF $DATA(^LR(LRDFN,"BB",IVDT,99))
SET Y1="Specimen Comment: "
SET IFN=0
FOR
SET IFN=$ORDER(^LR(LRDFN,"BB",IVDT,99,IFN))
IF IFN<1
QUIT
SET Y2=^(IFN,0)
SET ^TMP("LRX",$JOB,69,CTR,63,"N",IFN)=Y1_"^"_Y2
+10 QUIT
+11 ;
+12 ;
EM ;Electron Microscopy
+1 DO SS^LR7OB63C("EM")
+2 QUIT
+3 ;
+4 ;
SP ;Surgical Pathology
+1 DO SS^LR7OB63C("SP")
+2 QUIT
+3 ;
+4 ;
CY ;Cytology
+1 DO SS^LR7OB63C("CY")
+2 QUIT
+3 ;
+4 ;
AU ;Autopsy
+1 DO AU^LR7OB63D
+2 QUIT
+3 ;
+4 ;
NODEPIK(FILE,NODE,PIECE,DATA) ;Set field name and data into X
+1 NEW Z,Y,Y1,Y2
+2 SET Z=$ORDER(^DD(FILE,"GL",NODE,PIECE,0))
SET X=""
+3 IF Z
SET Y=^DD(FILE,Z,0)
SET Y1=$PIECE(Y,"^")
SET Y2=DATA
IF $PIECE(Y,"^",2)["S"
SET Y2=$$SET(FILE,Z,Y2)
IF $PIECE(Y,"^",2)["P"!($PIECE(Y,"^",2)["V")
SET Y2=$$POINTER(FILE,Z,Y2)
SET X=Y1_"^"_Y2
+4 QUIT X
+5 ;
+6 ;
UNIT(X,SPEC,SEX,DOB,AGE) ;Find units and ref range
+1 ;X=Result
+2 ;SPEC=Specimen ptr
+3 ;SEX=Patient sex
+4 ;DOB=Patient Date of birth
+5 ;AGE=Patient age
+6 ;Output: Y4=Units, Y5=Ref Range, Y14=T or "" (If T, range is theraputic)
+7 NEW LO,HI
+8 SET (Y4,Y5,Y14)=""
+9 ;No units/ranges defined
IF '$DATA(^LAB(60,+X,1,+SPEC,0))
QUIT
SET X=^(0)
+10 SET Y4=$PIECE(X,"^",7)
+11 SET @("LO="_$SELECT($LENGTH($PIECE(X,"^",2)):$PIECE(X,"^",2),$LENGTH($PIECE(X,"^",11)):$PIECE(X,"^",11),1:""""""))
+12 SET @("HI="_$SELECT($LENGTH($PIECE(X,"^",3)):$PIECE(X,"^",3),$LENGTH($PIECE(X,"^",12)):$PIECE(X,"^",12),1:""""""))
+13 SET Y5=$SELECT($LENGTH(HI):LO_"-"_HI,1:LO)
+14 SET Y14=$SELECT('$LENGTH($PIECE(X,"^",2))&$LENGTH($PIECE(X,"^",11)):"T",1:"")
+15 QUIT
+16 ;
+17 ;
RESULT(TEST,RESULT) ;Convert result to external format
+1 ;TEST=Test ptr to file 60
+2 ;RESULT=Test result
+3 NEW X,X1,LRCW
+4 SET LRCW=""
SET X1=$PIECE($GET(^LAB(60,TEST,.1)),"^",3)
SET X1=$SELECT($LENGTH(X1):X1,1:"$J(X,8)")
SET X=RESULT
SET @("X="_X1)
+5 QUIT X
+6 ;
+7 ;
STRIP(TEXT) ;Strips white space from text
+1 NEW I,X
+2 SET X=""
FOR I=1:1:$LENGTH(TEXT," ")
IF $ASCII($PIECE(TEXT," ",I))>0
SET X=X_$PIECE(TEXT," ",I)
+3 QUIT X
+4 ;
+5 ;
SET(FILE,FIELD,RESULT) ;Interpret set of codes
+1 SET X=$PIECE(^DD(FILE,FIELD,0),"^",3)
SET X=$PIECE($PIECE(";"_X,";"_RESULT_":",2),";")
+2 QUIT X
+3 ;
+4 ;
POINTER(FILE,FIELD,RESULT) ;Interpret pointer values
+1 NEW X
+2 SET X=$PIECE(^DD(FILE,FIELD,0),"^",2)
+3 IF X["V"
SET X1=@("^"_$PIECE(RESULT,";",2)_+RESULT_",0)")
+4 IF X'["V"
SET X1=$PIECE(@("^"_$PIECE(^DD(FILE,FIELD,0),"^",3)_RESULT_",0)"),"^")
+5 QUIT X1
