LRRPU ;DALOI/JMC - Interim Report Results Utility ; May 10, 2004 0900
;;5.2;LAB SERVICE;**286**;Sep 27, 1994
;
;
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))
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=""
. 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)
. 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRPU 3999 printed Dec 13, 2024@02:20:11 Page 2
LRRPU ;DALOI/JMC - Interim Report Results Utility ; May 10, 2004 0900
+1 ;;5.2;LAB SERVICE;**286**;Sep 27, 1994
+2 ;
+3 ;
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 SET LRY=$PIECE(LRX,"^",1,2)
SET $PIECE(LRY,"^",7)=0
+14 IF LRSS="CH"
IF $$GET1^DID(63.04,LRDN,"","TYPE")="SET"
Begin DoDot:1
+15 SET X=$$EXTERNAL^DILFD(63.04,LRDN,"",$PIECE(LRY,"^"))
+16 IF X'=""
SET $PIECE(LRY,"^")=X
End DoDot:1
+17 ;
+18 ; Check for units/ranges stored in file #63
+19 ; If flag (NPC>1) indicates units/ranges are stored but pieces 5-12
+20 ; are null then use values from file #60 - some class III software
+21 ; still does not store this info in file #63 when NPC>1.
+22 SET LRFLAG=0
SET LRNR=$TRANSLATE($PIECE(LRX,"^",5),"!","^")
+23 IF $GET(^LR(LRDFN,LRSS,LRIDT,"NPC"))>1
IF $PIECE(LRX,"^",5,12)'=""
SET LRFLAG=1
+24 ;
+25 IF LRFLAG
Begin DoDot:1
+26 IF $PIECE(LRNR,"^",11)=""
IF $PIECE(LRNR,"^",12)=""
SET $PIECE(LRY,"^",3,4)=$PIECE(LRNR,"^",2,3)
+27 IF '$TEST
SET $PIECE(LRY,"^",3,4)=$PIECE(LRNR,"^",11,12)
SET $PIECE(LRY,"^",7)=1
+28 SET $PIECE(LRY,"^",5)=$PIECE(LRNR,"^",7)
End DoDot:1
+29 ;
+30 ; If no units/ranges (LRFLAG=0) then use file 60
+31 ; values to determine reference ranges
+32 ; If no therapeutic normals then return reference normals
+33 ; Need to handle age and sex in normals from file #60
+34 IF 'LRFLAG
Begin DoDot:1
+35 NEW AGE,DOB,LR61,LRCDT,LRDPF,LRLO,LRHI,LRTLO,LRTHI,SEX,X
+36 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+37 SET X=$GET(^LR(LRDFN,LRSS,LRIDT,0))
SET LRCDT=$PIECE(X,"^")
SET LR61=+$PIECE(X,"^",5)
+38 SET X=$$ROOT^DILFD(+LRDPF)
+39 SET SEX=$PIECE($GET(@(X_+DFN_",0)")),"^",2)
SET DOB=$PIECE($GET(@(X_+DFN_",0)")),"^",3)
+40 SET AGE=$$CALCAGE(DOB,LRCDT)
+41 IF '$GET(LR60)
SET LR60=+$ORDER(^LAB(60,"C","CH;"_LRDN_";1",0))
+42 SET X=$GET(^LAB(60,LR60,1,LR61,0))
if X=""
QUIT
+43 SET $PIECE(LRY,"^",5)=$PIECE(X,"^",7)
+44 SET LRLO=$PIECE(X,U,2)
SET LRHI=$PIECE(X,U,3)
SET LRTLO=$PIECE(X,U,11)
SET LRTHI=$PIECE(X,U,12)
+45 IF LRTLO=""
IF LRTHI=""
Begin DoDot:2
+46 IF LRLO'=""
SET @("LRLO="_LRLO)
+47 IF LRHI'=""
SET @("LRHI="_LRHI)
+48 SET $PIECE(LRY,"^",3)=LRLO
SET $PIECE(LRY,"^",4)=LRHI
End DoDot:2
QUIT
+49 IF LRTLO'=""
SET @("LRTLO="_LRTLO)
+50 IF LRTHI'=""
SET @("LRTHI="_LRTHI)
+51 SET $PIECE(LRY,"^",3)=LRTLO
SET $PIECE(LRY,"^",4)=LRTHI
SET $PIECE(LRY,"^",7)=1
End DoDot:1
+52 ;
+53 ; Remove leading/trailing quotes from normals.
+54 IF $PIECE(LRY,"^",3)[$CHAR(34)
SET $PIECE(LRY,"^",3)=$$TRIM^XLFSTR($PIECE(LRY,"^",3),"LR",$CHAR(34))
+55 IF $PIECE(LRY,"^",4)[$CHAR(34)
SET $PIECE(LRY,"^",4)=$$TRIM^XLFSTR($PIECE(LRY,"^",4),"LR",$CHAR(34))
+56 ; Performing laboratory
+57 SET $PIECE(LRY,"^",6)=$PIECE(LRX,"^",9)
+58 ;
+59 ; Return NLT/LOINC codes
+60 IF $GET(LRCODE)=1
Begin DoDot:1
+61 NEW LR64
+62 SET X=$PIECE($PIECE(LRX,"^",3),"!",1,3)
+63 FOR I=1,2
IF $PIECE(X,"!",I)'=""
Begin DoDot:2
+64 SET LR64=$ORDER(^LAM("E",$PIECE(X,"!",I),0))
SET Y=""
+65 IF LR64
SET Y=$$GET1^DIQ(64,LR64_",",.01,"I")
+66 IF Y'=""
IF Y["!"
SET Y=$TRANSLATE(Y,"!","*")
+67 SET $PIECE(X,"!",I)=$PIECE(X,"!",I)_";"_Y
End DoDot:2
+68 IF $PIECE(X,"!",3)'=""
Begin DoDot:2
+69 SET Y=$$GET1^DIQ(95.3,$PIECE(X,"!",3)_",",.01)
+70 SET Y(0)=$$GET1^DIQ(95.3,$PIECE(X,"!",3)_",",80)
+71 IF Y(0)["!"
SET Y(0)=$TRANSLATE(Y(0),"!","*")
+72 SET $PIECE(X,"!",3)=Y_";"_Y(0)
End DoDot:2
+73 SET $PIECE(LRY,"^",8)=X
End DoDot:1
+74 ;
+75 ; Performing user
+76 SET $PIECE(LRY,"^",9)=$PIECE(LRX,"^",4)
+77 ; EII - Equipment instance Identifier
+78 SET $PIECE(LRY,"^",10)=$PIECE(LRX,"^",11)
+79 ;
+80 QUIT LRY
+81 ;
+82 ;
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
