LRRPU ;VA/DALOI/JMC - Interim Report Results Utility ; 22-Oct-2013 09:22 ; MKK
;;5.2;LAB SERVICE;**1027,1028,1031,1033**;NOV 01, 1997
;
;;VA LR Patche(s): 286
;
TSTRES(LRDFN,LRSS,LRIDT,LRDN,LR60,LRCODE) ; Test results and parameters
; Call with LRDFN = ien of entry in file #63
; LRSS = subscript in file #63, currently only "CH" supported
; LRIDT = inverse date/time of result
; LRDN = ien of data name in "CH" subscript
; LR60 = pointer to file 60 test related to this dataname (optional)
; LRCODE = 1 - return NLT/LOINC codes (optional)
;
; Returns
; LRY = result^normalcy flag^reference low^reference high^units^performing lab (file #4 ien)^therapeutic normal used (0=no/1=yes)^NLT order code;NLT name!NLT result code;NLT name!LOINC result code;LOINC name^performing user (DUZ)^EII
;
N LRFLAG,LRNR,LRX,LRY,X,Y
S LRX=$G(^LR(LRDFN,LRSS,LRIDT,LRDN))
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1031
; Ensure that all Results have leading zeros, if necessary
NEW ZFRES
S ZFRES=$P(LRX,"^",1)
; D ZEROFIX^BLR7OGMP(LR60,.ZFRES)
D:+$G(LR60) ZEROFIX^BLR7OGMP(LR60,.ZFRES) ; IHS/MSC/MKK - LR*5.2*1033
S $P(LRX,"^")=ZFRES
K ZFRES
; ----- END IHS/OIT/MKK - LR*5.2*1031
;
S LRY=$P(LRX,"^",1,2),$P(LRY,"^",7)=0
I LRSS="CH",$$GET1^DID(63.04,LRDN,"","TYPE")="SET" D
. S X=$$EXTERNAL^DILFD(63.04,LRDN,"",$P(LRY,"^"))
. I X'="" S $P(LRY,"^")=X
;
; Check for units/ranges stored in file #63
; If flag (NPC>1) indicates units/ranges are stored but pieces 5-12
; are null then use values from file #60 - some class III software
; still does not store this info in file #63 when NPC>1.
S LRFLAG=0,LRNR=$TR($P(LRX,"^",5),"!","^")
I $G(^LR(LRDFN,LRSS,LRIDT,"NPC"))>1,$P(LRX,"^",5,12)'="" S LRFLAG=1
;
I LRFLAG D
. I $P(LRNR,"^",11)="",$P(LRNR,"^",12)="" S $P(LRY,"^",3,4)=$P(LRNR,"^",2,3)
. E S $P(LRY,"^",3,4)=$P(LRNR,"^",11,12),$P(LRY,"^",7)=1
. S $P(LRY,"^",5)=$P(LRNR,"^",7)
;
; If no units/ranges (LRFLAG=0) then use file 60
; values to determine reference ranges
; If no therapeutic normals then return reference normals
; Need to handle age and sex in normals from file #60
I 'LRFLAG D
. N AGE,DOB,LR61,LRCDT,LRDPF,LRLO,LRHI,LRTLO,LRTHI,SEX,X
. S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
. S X=$G(^LR(LRDFN,LRSS,LRIDT,0)),LRCDT=$P(X,"^"),LR61=+$P(X,"^",5)
. S X=$$ROOT^DILFD(+LRDPF)
. S SEX=$P($G(@(X_+DFN_",0)")),"^",2),DOB=$P($G(@(X_+DFN_",0)")),"^",3)
. S AGE=$$CALCAGE(DOB,LRCDT)
. I '$G(LR60) S LR60=+$O(^LAB(60,"C","CH;"_LRDN_";1",0))
. S X=$G(^LAB(60,LR60,1,LR61,0)) Q:X=""
. ;[LR*5.2*1028;04/20/11;IHS.OIT/MPW]Added next 1 line.
. I $P(X,"^",7)?1N.N S $P(X,"^",7)=$P(^BLRUCUM($P(X,"^",7),0),U,1)
. S $P(LRY,"^",5)=$P(X,"^",7)
. S LRLO=$P(X,U,2),LRHI=$P(X,U,3),LRTLO=$P(X,U,11),LRTHI=$P(X,U,12)
. ;
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
. ; Ensure Ref Ranges have leading zeros, if necessary
. I +LRLO D ZEROFIX(LR60,.LRLO)
. I +LRHI D ZEROFIX(LR60,.LRHI)
. ; ----- END IHS/MSC/MKK - LR*5.2*1031
. ;
. I LRTLO="",LRTHI="" D Q
. . I LRLO'="" S @("LRLO="_LRLO)
. . I LRHI'="" S @("LRHI="_LRHI)
. . S $P(LRY,"^",3)=LRLO,$P(LRY,"^",4)=LRHI
. I LRTLO'="" S @("LRTLO="_LRTLO)
. I LRTHI'="" S @("LRTHI="_LRTHI)
. S $P(LRY,"^",3)=LRTLO,$P(LRY,"^",4)=LRTHI,$P(LRY,"^",7)=1
;
; Remove leading/trailing quotes from normals.
I $P(LRY,"^",3)[$C(34) S $P(LRY,"^",3)=$$TRIM^XLFSTR($P(LRY,"^",3),"LR",$C(34))
I $P(LRY,"^",4)[$C(34) S $P(LRY,"^",4)=$$TRIM^XLFSTR($P(LRY,"^",4),"LR",$C(34))
; Performing laboratory
S $P(LRY,"^",6)=$P(LRX,"^",9)
;
; Return NLT/LOINC codes
I $G(LRCODE)=1 D
. N LR64
. S X=$P($P(LRX,"^",3),"!",1,3)
. F I=1,2 I $P(X,"!",I)'="" D
. . S LR64=$O(^LAM("E",$P(X,"!",I),0)),Y=""
. . I LR64 S Y=$$GET1^DIQ(64,LR64_",",.01,"I")
. . I Y'="",Y["!" S Y=$TR(Y,"!","*")
. . S $P(X,"!",I)=$P(X,"!",I)_";"_Y
. I $P(X,"!",3)'="" D
. . S Y=$$GET1^DIQ(95.3,$P(X,"!",3)_",",.01)
. . S Y(0)=$$GET1^DIQ(95.3,$P(X,"!",3)_",",80)
. . I Y(0)["!" S Y(0)=$TR(Y(0),"!","*")
. . S $P(X,"!",3)=Y_";"_Y(0)
. S $P(LRY,"^",8)=X
;
; Performing user
S $P(LRY,"^",9)=$P(LRX,"^",4)
; EII - Equipment instance Identifier
S $P(LRY,"^",10)=$P(LRX,"^",11)
;
Q LRY
;
;
CALCAGE(DOB,LRCDT) ; Calculate age based on difference between DOB and collection date.
;
; Call with DOB = patient date of birth
; LRCDT = specimen collection date
;
; Returns AGE = patient's age in years at time of specimen collection
;
I $T(DATE^LRDAGE)'="" Q $$DATE^LRDAGE(DOB,LRCDT)
;
S AGE=99
I DOB>2000000,LRCDT>2000000,DOB'>LRCDT S X=$$FMDIFF^XLFDT(LRCDT,DOB,1),AGE=X\365.25
Q AGE
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX(F60PTR,RESULT) ; EP - Leading & Trailing Zero Fix for Results
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60PTR,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,RESULT,U,XPARSYS,XQXFLG)
;
Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB" ; Skip if not resulted
;
Q:$L($G(RESULT))<1 ; Skip if no Result
;
Q:$L($G(F60PTR))<1 ; Skip if no File 60 Pointer
;
S DN=+$G(^LAB(60,F60PTR,.2))
Q:DN<1 ; Skip if no DataName
;
Q:$G(^DD(63.04,DN,0))'["^LRNUM" ; Skip if no numeric defintiion
;
S STR=$P($P($G(^DD(63.04,DN,0)),"Q9=",2),$C(34),2) ; Get numeric formatting
;
S DP=+$P(STR,",",3) ; Decimal Places
Q:DP<1 ; Skip if no Decimal Defintion
;
S SYMBOL="",ORIGRSLT=RESULT
F Q:$E(RESULT)="."!($E(RESULT)?1N)!(RESULT="") D ; Adjust if ANY Non-Numeric is at the beginning of RESULT
. S SYMBOL=SYMBOL_$E(RESULT)
. S RESULT=$E(RESULT,2,$L(RESULT))
;
S:$E(RESULT)="." RESULT="0"_RESULT ; Leading Zero Fix
;
I $E(RESULT)'?1N S RESULT=ORIGRSLT Q ; Skip if RESULT has no numeric part
;
S RESULT=$TR($FN(RESULT,"P",DP)," ")
;
S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT ; Restore "symbol", if necessary
;
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
LRRPU ;VA/DALOI/JMC - Interim Report Results Utility ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1027,1028,1031,1033**;NOV 01, 1997
+2 ;
+3 ;;VA LR Patche(s): 286
+4 ;
TSTRES(LRDFN,LRSS,LRIDT,LRDN,LR60,LRCODE) ; Test results and parameters
+1 ; Call with LRDFN = ien of entry in file #63
+2 ; LRSS = subscript in file #63, currently only "CH" supported
+3 ; LRIDT = inverse date/time of result
+4 ; LRDN = ien of data name in "CH" subscript
+5 ; LR60 = pointer to file 60 test related to this dataname (optional)
+6 ; LRCODE = 1 - return NLT/LOINC codes (optional)
+7 ;
+8 ; Returns
+9 ; LRY = result^normalcy flag^reference low^reference high^units^performing lab (file #4 ien)^therapeutic normal used (0=no/1=yes)^NLT order code;NLT name!NLT result code;NLT name!LOINC result code;LOINC name^performing user (DUZ)^EII
+10 ;
+11 NEW LRFLAG,LRNR,LRX,LRY,X,Y
+12 SET LRX=$GET(^LR(LRDFN,LRSS,LRIDT,LRDN))
+13 ;
+14 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1031
+15 ; Ensure that all Results have leading zeros, if necessary
+16 NEW ZFRES
+17 SET ZFRES=$PIECE(LRX,"^",1)
+18 ; D ZEROFIX^BLR7OGMP(LR60,.ZFRES)
+19 ; IHS/MSC/MKK - LR*5.2*1033
IF +$GET(LR60)
DO ZEROFIX^BLR7OGMP(LR60,.ZFRES)
+20 SET $PIECE(LRX,"^")=ZFRES
+21 KILL ZFRES
+22 ; ----- END IHS/OIT/MKK - LR*5.2*1031
+23 ;
+24 SET LRY=$PIECE(LRX,"^",1,2)
SET $PIECE(LRY,"^",7)=0
+25 IF LRSS="CH"
IF $$GET1^DID(63.04,LRDN,"","TYPE")="SET"
Begin DoDot:1
+26 SET X=$$EXTERNAL^DILFD(63.04,LRDN,"",$PIECE(LRY,"^"))
+27 IF X'=""
SET $PIECE(LRY,"^")=X
End DoDot:1
+28 ;
+29 ; Check for units/ranges stored in file #63
+30 ; If flag (NPC>1) indicates units/ranges are stored but pieces 5-12
+31 ; are null then use values from file #60 - some class III software
+32 ; still does not store this info in file #63 when NPC>1.
+33 SET LRFLAG=0
SET LRNR=$TRANSLATE($PIECE(LRX,"^",5),"!","^")
+34 IF $GET(^LR(LRDFN,LRSS,LRIDT,"NPC"))>1
IF $PIECE(LRX,"^",5,12)'=""
SET LRFLAG=1
+35 ;
+36 IF LRFLAG
Begin DoDot:1
+37 IF $PIECE(LRNR,"^",11)=""
IF $PIECE(LRNR,"^",12)=""
SET $PIECE(LRY,"^",3,4)=$PIECE(LRNR,"^",2,3)
+38 IF '$TEST
SET $PIECE(LRY,"^",3,4)=$PIECE(LRNR,"^",11,12)
SET $PIECE(LRY,"^",7)=1
+39 SET $PIECE(LRY,"^",5)=$PIECE(LRNR,"^",7)
End DoDot:1
+40 ;
+41 ; If no units/ranges (LRFLAG=0) then use file 60
+42 ; values to determine reference ranges
+43 ; If no therapeutic normals then return reference normals
+44 ; Need to handle age and sex in normals from file #60
+45 IF 'LRFLAG
Begin DoDot:1
+46 NEW AGE,DOB,LR61,LRCDT,LRDPF,LRLO,LRHI,LRTLO,LRTHI,SEX,X
+47 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+48 SET X=$GET(^LR(LRDFN,LRSS,LRIDT,0))
SET LRCDT=$PIECE(X,"^")
SET LR61=+$PIECE(X,"^",5)
+49 SET X=$$ROOT^DILFD(+LRDPF)
+50 SET SEX=$PIECE($GET(@(X_+DFN_",0)")),"^",2)
SET DOB=$PIECE($GET(@(X_+DFN_",0)")),"^",3)
+51 SET AGE=$$CALCAGE(DOB,LRCDT)
+52 IF '$GET(LR60)
SET LR60=+$ORDER(^LAB(60,"C","CH;"_LRDN_";1",0))
+53 SET X=$GET(^LAB(60,LR60,1,LR61,0))
IF X=""
QUIT
+54 ;[LR*5.2*1028;04/20/11;IHS.OIT/MPW]Added next 1 line.
+55 IF $PIECE(X,"^",7)?1N.N
SET $PIECE(X,"^",7)=$PIECE(^BLRUCUM($PIECE(X,"^",7),0),U,1)
+56 SET $PIECE(LRY,"^",5)=$PIECE(X,"^",7)
+57 SET LRLO=$PIECE(X,U,2)
SET LRHI=$PIECE(X,U,3)
SET LRTLO=$PIECE(X,U,11)
SET LRTHI=$PIECE(X,U,12)
+58 ;
+59 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+60 ; Ensure Ref Ranges have leading zeros, if necessary
+61 IF +LRLO
DO ZEROFIX(LR60,.LRLO)
+62 IF +LRHI
DO ZEROFIX(LR60,.LRHI)
+63 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+64 ;
+65 IF LRTLO=""
IF LRTHI=""
Begin DoDot:2
+66 IF LRLO'=""
SET @("LRLO="_LRLO)
+67 IF LRHI'=""
SET @("LRHI="_LRHI)
+68 SET $PIECE(LRY,"^",3)=LRLO
SET $PIECE(LRY,"^",4)=LRHI
End DoDot:2
QUIT
+69 IF LRTLO'=""
SET @("LRTLO="_LRTLO)
+70 IF LRTHI'=""
SET @("LRTHI="_LRTHI)
+71 SET $PIECE(LRY,"^",3)=LRTLO
SET $PIECE(LRY,"^",4)=LRTHI
SET $PIECE(LRY,"^",7)=1
End DoDot:1
+72 ;
+73 ; Remove leading/trailing quotes from normals.
+74 IF $PIECE(LRY,"^",3)[$CHAR(34)
SET $PIECE(LRY,"^",3)=$$TRIM^XLFSTR($PIECE(LRY,"^",3),"LR",$CHAR(34))
+75 IF $PIECE(LRY,"^",4)[$CHAR(34)
SET $PIECE(LRY,"^",4)=$$TRIM^XLFSTR($PIECE(LRY,"^",4),"LR",$CHAR(34))
+76 ; Performing laboratory
+77 SET $PIECE(LRY,"^",6)=$PIECE(LRX,"^",9)
+78 ;
+79 ; Return NLT/LOINC codes
+80 IF $GET(LRCODE)=1
Begin DoDot:1
+81 NEW LR64
+82 SET X=$PIECE($PIECE(LRX,"^",3),"!",1,3)
+83 FOR I=1,2
IF $PIECE(X,"!",I)'=""
Begin DoDot:2
+84 SET LR64=$ORDER(^LAM("E",$PIECE(X,"!",I),0))
SET Y=""
+85 IF LR64
SET Y=$$GET1^DIQ(64,LR64_",",.01,"I")
+86 IF Y'=""
IF Y["!"
SET Y=$TRANSLATE(Y,"!","*")
+87 SET $PIECE(X,"!",I)=$PIECE(X,"!",I)_";"_Y
End DoDot:2
+88 IF $PIECE(X,"!",3)'=""
Begin DoDot:2
+89 SET Y=$$GET1^DIQ(95.3,$PIECE(X,"!",3)_",",.01)
+90 SET Y(0)=$$GET1^DIQ(95.3,$PIECE(X,"!",3)_",",80)
+91 IF Y(0)["!"
SET Y(0)=$TRANSLATE(Y(0),"!","*")
+92 SET $PIECE(X,"!",3)=Y_";"_Y(0)
End DoDot:2
+93 SET $PIECE(LRY,"^",8)=X
End DoDot:1
+94 ;
+95 ; Performing user
+96 SET $PIECE(LRY,"^",9)=$PIECE(LRX,"^",4)
+97 ; EII - Equipment instance Identifier
+98 SET $PIECE(LRY,"^",10)=$PIECE(LRX,"^",11)
+99 ;
+100 QUIT LRY
+101 ;
+102 ;
CALCAGE(DOB,LRCDT) ; Calculate age based on difference between DOB and collection date.
+1 ;
+2 ; Call with DOB = patient date of birth
+3 ; LRCDT = specimen collection date
+4 ;
+5 ; Returns AGE = patient's age in years at time of specimen collection
+6 ;
+7 IF $TEXT(DATE^LRDAGE)'=""
QUIT $$DATE^LRDAGE(DOB,LRCDT)
+8 ;
+9 SET AGE=99
+10 IF DOB>2000000
IF LRCDT>2000000
IF DOB'>LRCDT
SET X=$$FMDIFF^XLFDT(LRCDT,DOB,1)
SET AGE=X\365.25
+11 QUIT AGE
+12 ;
+13 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX(F60PTR,RESULT) ; EP - Leading & Trailing Zero Fix for Results
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,F60PTR,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,RESULT,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Skip if not resulted
IF $$UP^XLFSTR($GET(RESULT))["SPECIMEN IN LAB"
QUIT
+4 ;
+5 ; Skip if no Result
IF $LENGTH($GET(RESULT))<1
QUIT
+6 ;
+7 ; Skip if no File 60 Pointer
IF $LENGTH($GET(F60PTR))<1
QUIT
+8 ;
+9 SET DN=+$GET(^LAB(60,F60PTR,.2))
+10 ; Skip if no DataName
IF DN<1
QUIT
+11 ;
+12 ; Skip if no numeric defintiion
IF $GET(^DD(63.04,DN,0))'["^LRNUM"
QUIT
+13 ;
+14 ; Get numeric formatting
SET STR=$PIECE($PIECE($GET(^DD(63.04,DN,0)),"Q9=",2),$CHAR(34),2)
+15 ;
+16 ; Decimal Places
SET DP=+$PIECE(STR,",",3)
+17 ; Skip if no Decimal Defintion
IF DP<1
QUIT
+18 ;
+19 SET SYMBOL=""
SET ORIGRSLT=RESULT
+20 ; Adjust if ANY Non-Numeric is at the beginning of RESULT
FOR
IF $EXTRACT(RESULT)="."!($EXTRACT(RESULT)?1N)!(RESULT="")
QUIT
Begin DoDot:1
+21 SET SYMBOL=SYMBOL_$EXTRACT(RESULT)
+22 SET RESULT=$EXTRACT(RESULT,2,$LENGTH(RESULT))
End DoDot:1
+23 ;
+24 ; Leading Zero Fix
IF $EXTRACT(RESULT)="."
SET RESULT="0"_RESULT
+25 ;
+26 ; Skip if RESULT has no numeric part
IF $EXTRACT(RESULT)'?1N
SET RESULT=ORIGRSLT
QUIT
+27 ;
+28 SET RESULT=$TRANSLATE($FNUMBER(RESULT,"P",DP)," ")
+29 ;
+30 ; Restore "symbol", if necessary
IF $LENGTH($GET(SYMBOL))
SET RESULT=SYMBOL_RESULT
+31 ;
+32 QUIT
+33 ; ----- END IHS/MSC/MKK - LR*5.2*1031
