Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRRPU

LRRPU.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;;VA LR Patche(s): 286
  1.  ;
  1. TSTRES(LRDFN,LRSS,LRIDT,LRDN,LR60,LRCODE) ; Test results and parameters
  1.  ; Call with LRDFN = ien of entry in file #63
  1.  ;            LRSS = subscript in file #63, currently only "CH" supported
  1.  ;           LRIDT = inverse date/time of result
  1.  ;            LRDN = ien of data name in "CH" subscript
  1.  ;            LR60 = pointer to file 60 test related to this dataname (optional)
  1.  ;          LRCODE = 1 - return NLT/LOINC codes (optional)
  1.  ;
  1.  ; Returns
  1.  ;  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
  1.  ;
  1.  N LRFLAG,LRNR,LRX,LRY,X,Y
  1.  S LRX=$G(^LR(LRDFN,LRSS,LRIDT,LRDN))
  1.  ;
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1031
  1.  ;       Ensure that all Results have leading zeros, if necessary
  1.  NEW ZFRES
  1.  S ZFRES=$P(LRX,"^",1)
  1.  ; D ZEROFIX^BLR7OGMP(LR60,.ZFRES)
  1.  D:+$G(LR60) ZEROFIX^BLR7OGMP(LR60,.ZFRES)  ; IHS/MSC/MKK - LR*5.2*1033
  1.  S $P(LRX,"^")=ZFRES
  1.  K ZFRES
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1031
  1.  ;
  1.  S LRY=$P(LRX,"^",1,2),$P(LRY,"^",7)=0
  1.  I LRSS="CH",$$GET1^DID(63.04,LRDN,"","TYPE")="SET" D
  1.  . S X=$$EXTERNAL^DILFD(63.04,LRDN,"",$P(LRY,"^"))
  1.  . I X'="" S $P(LRY,"^")=X
  1.  ;
  1.  ; Check for units/ranges stored in file #63
  1.  ; If flag (NPC>1) indicates units/ranges are stored but pieces 5-12
  1.  ; are null then use values from file #60 - some class III software
  1.  ; still does not store this info in file #63 when NPC>1.
  1.  S LRFLAG=0,LRNR=$TR($P(LRX,"^",5),"!","^")
  1.  I $G(^LR(LRDFN,LRSS,LRIDT,"NPC"))>1,$P(LRX,"^",5,12)'="" S LRFLAG=1
  1.  ;
  1.  I LRFLAG D
  1.  . I $P(LRNR,"^",11)="",$P(LRNR,"^",12)="" S $P(LRY,"^",3,4)=$P(LRNR,"^",2,3)
  1.  . E  S $P(LRY,"^",3,4)=$P(LRNR,"^",11,12),$P(LRY,"^",7)=1
  1.  . S $P(LRY,"^",5)=$P(LRNR,"^",7)
  1.  ;
  1.  ; If no units/ranges (LRFLAG=0) then use file 60
  1.  ; values to determine reference ranges
  1.  ; If no therapeutic normals then return reference normals
  1.  ; Need to handle age and sex in normals from file #60
  1.  I 'LRFLAG D
  1.  . N AGE,DOB,LR61,LRCDT,LRDPF,LRLO,LRHI,LRTLO,LRTHI,SEX,X
  1.  . S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1.  . S X=$G(^LR(LRDFN,LRSS,LRIDT,0)),LRCDT=$P(X,"^"),LR61=+$P(X,"^",5)
  1.  . S X=$$ROOT^DILFD(+LRDPF)
  1.  . S SEX=$P($G(@(X_+DFN_",0)")),"^",2),DOB=$P($G(@(X_+DFN_",0)")),"^",3)
  1.  . S AGE=$$CALCAGE(DOB,LRCDT)
  1.  . I '$G(LR60) S LR60=+$O(^LAB(60,"C","CH;"_LRDN_";1",0))
  1.  . S X=$G(^LAB(60,LR60,1,LR61,0)) Q:X=""
  1.  . ;[LR*5.2*1028;04/20/11;IHS.OIT/MPW]Added next 1 line.
  1.  . I $P(X,"^",7)?1N.N S $P(X,"^",7)=$P(^BLRUCUM($P(X,"^",7),0),U,1)
  1.  . S $P(LRY,"^",5)=$P(X,"^",7)
  1.  . S LRLO=$P(X,U,2),LRHI=$P(X,U,3),LRTLO=$P(X,U,11),LRTHI=$P(X,U,12)
  1.  . ;
  1.  . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  . ;       Ensure Ref Ranges have leading zeros, if necessary
  1.  . I +LRLO D ZEROFIX(LR60,.LRLO)
  1.  . I +LRHI D ZEROFIX(LR60,.LRHI)
  1.  . ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  . ;
  1.  . I LRTLO="",LRTHI="" D  Q
  1.  . . I LRLO'="" S @("LRLO="_LRLO)
  1.  . . I LRHI'="" S @("LRHI="_LRHI)
  1.  . . S $P(LRY,"^",3)=LRLO,$P(LRY,"^",4)=LRHI
  1.  . I LRTLO'="" S @("LRTLO="_LRTLO)
  1.  . I LRTHI'="" S @("LRTHI="_LRTHI)
  1.  . S $P(LRY,"^",3)=LRTLO,$P(LRY,"^",4)=LRTHI,$P(LRY,"^",7)=1
  1.  ;
  1.  ; Remove leading/trailing quotes from normals.
  1.  I $P(LRY,"^",3)[$C(34) S $P(LRY,"^",3)=$$TRIM^XLFSTR($P(LRY,"^",3),"LR",$C(34))
  1.  I $P(LRY,"^",4)[$C(34) S $P(LRY,"^",4)=$$TRIM^XLFSTR($P(LRY,"^",4),"LR",$C(34))
  1.  ; Performing laboratory
  1.  S $P(LRY,"^",6)=$P(LRX,"^",9)
  1.  ;
  1.  ; Return NLT/LOINC codes
  1.  I $G(LRCODE)=1 D
  1.  . N LR64
  1.  . S X=$P($P(LRX,"^",3),"!",1,3)
  1.  . F I=1,2 I $P(X,"!",I)'="" D
  1.  . . S LR64=$O(^LAM("E",$P(X,"!",I),0)),Y=""
  1.  . . I LR64 S Y=$$GET1^DIQ(64,LR64_",",.01,"I")
  1.  . . I Y'="",Y["!" S Y=$TR(Y,"!","*")
  1.  . . S $P(X,"!",I)=$P(X,"!",I)_";"_Y
  1.  . I $P(X,"!",3)'="" D
  1.  . . S Y=$$GET1^DIQ(95.3,$P(X,"!",3)_",",.01)
  1.  . . S Y(0)=$$GET1^DIQ(95.3,$P(X,"!",3)_",",80)
  1.  . . I Y(0)["!" S Y(0)=$TR(Y(0),"!","*")
  1.  . . S $P(X,"!",3)=Y_";"_Y(0)
  1.  . S $P(LRY,"^",8)=X
  1.  ;
  1.  ; Performing user
  1.  S $P(LRY,"^",9)=$P(LRX,"^",4)
  1.  ; EII - Equipment instance Identifier
  1.  S $P(LRY,"^",10)=$P(LRX,"^",11)
  1.  ;
  1.  Q LRY
  1.  ;
  1.  ;
  1. CALCAGE(DOB,LRCDT) ; Calculate age based on difference between DOB and collection date.
  1.  ;
  1.  ; Call with DOB = patient date of birth
  1.  ;         LRCDT = specimen collection date
  1.  ;
  1.  ; Returns   AGE = patient's age in years at time of specimen collection
  1.  ;
  1.  I $T(DATE^LRDAGE)'="" Q $$DATE^LRDAGE(DOB,LRCDT)
  1.  ;
  1.  S AGE=99
  1.  I DOB>2000000,LRCDT>2000000,DOB'>LRCDT S X=$$FMDIFF^XLFDT(LRCDT,DOB,1),AGE=X\365.25
  1.  Q AGE
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1. 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)
  1.  ;
  1.  Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB"          ; Skip if not resulted
  1.  ;
  1.  Q:$L($G(RESULT))<1                      ; Skip if no Result
  1.  ;
  1.  Q:$L($G(F60PTR))<1                      ; Skip if no File 60 Pointer
  1.  ;
  1.  S DN=+$G(^LAB(60,F60PTR,.2))
  1.  Q:DN<1                                  ; Skip if no DataName
  1.  ;
  1.  Q:$G(^DD(63.04,DN,0))'["^LRNUM"         ; Skip if no numeric defintiion
  1.  ;
  1.  S STR=$P($P($G(^DD(63.04,DN,0)),"Q9=",2),$C(34),2)     ; Get numeric formatting
  1.  ;
  1.  S DP=+$P(STR,",",3)                     ; Decimal Places
  1.  Q:DP<1                                  ; Skip if no Decimal Defintion
  1.  ;
  1.  S SYMBOL="",ORIGRSLT=RESULT
  1.  F  Q:$E(RESULT)="."!($E(RESULT)?1N)!(RESULT="")  D       ; Adjust if ANY Non-Numeric is at the beginning of RESULT
  1.  . S SYMBOL=SYMBOL_$E(RESULT)
  1.  . S RESULT=$E(RESULT,2,$L(RESULT))
  1.  ;
  1.  S:$E(RESULT)="." RESULT="0"_RESULT      ; Leading Zero Fix
  1.  ;
  1.  I $E(RESULT)'?1N  S RESULT=ORIGRSLT  Q  ; Skip if RESULT has no numeric part
  1.  ;
  1.  S RESULT=$TR($FN(RESULT,"P",DP)," ")
  1.  ;
  1.  S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT   ; Restore "symbol", if necessary
  1.  ;
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031