GMTSLRSE ; SLC/JER,KER - Selected Lab Test Extract ; 09/21/2001
;;2.7;Health Summary;**28,36,47,79**;Oct 20, 1995
;
; External References
; DBIA 67 ^LAB(60
; DBIA 524 ^LAB(61
; DBIA 525 ^LR(
;
XTRCT ; Extract Selected Lab Test
;
; Call with LRDFN lab patient
; GMTS1 begin date
; GMTS2 end date
; MAX occurence limit
; SEX "M" or "F"
; TEST IFN to ^LAB(60)
; RWIDTH optional
;
; Returns ^TMP("LRS",$J,GMTSI,IDRWDT)=
; DRWDT^SPEC^TEST^RESULT^FLAG^UNIT^LO^HI
;
; Where GMTSI=Order (1 to MAX)
; IDRWDT=9999999-Draw Date/time
; DRWDT=Draw Date/Time (internal)
; SPEC=Specimen (int;ext)
; TEST=Test (int;ext)
; RESULT=Numeric Result
; FLAG=Reference flag (H,*H,L,*L)
; UNIT=Unit of measure (ext)
; LO=Reference/Therapeutic Lower bound
; HI=Ref/Ther Upper Bound
;
N CNT,AGE,COM,GMI,X K ^TMP("LRS",$J,GMTSI) I $S("BO"'[$P(^LAB(60,TEST,0),U,3):1,1:0) Q
D DEM^GMTSU S AGE=GMTSAGE S CNT=0 D CHEM:$P(^LAB(60,TEST,0),U,4)="CH"
Q
CHEM ; Gets all Chemistry tests w/in time/occurrence constraints
N PTR,IDRWDT S PTR=+$P($P(^LAB(60,+TEST,0),U,5),";",2),IDRWDT=GMTS1
F S IDRWDT=$O(^LR(LRDFN,"CH",IDRWDT)) Q:'IDRWDT!(IDRWDT>GMTS2)!(CNT'<MAX) I $P(^(IDRWDT,0),U,3),($D(^(PTR))) S CNT=CNT+1 D:CNT'>MAX CHSET
Q
CHSET ; Sets Chemistry locals for printing
N RESULT,FLAG,DRWDT,SITE,SPEC,TNM,DESCR,THER,UNIT,HI,LO,GMIDT,GMTSLRES
S GMTSLRES=$$TSTRES^LRRPU(LRDFN,"CH",IDRWDT,PTR)
; S RESULT=$P(^LR(LRDFN,"CH",IDRWDT,PTR),U),FLAG=$P(^(PTR),U,2),DRWDT=9999999-IDRWDT
S RESULT=$P(GMTSLRES,U,1),FLAG=$P(GMTSLRES,U,2),DRWDT=9999999-IDRWDT
S RESULT=$$RESULT^GMTSLRCE(TEST,RESULT,$G(RWIDTH))
S X=DRWDT D REGDTM4^GMTSU S DRWDT=X K X
S SITE=$P(^LR(LRDFN,"CH",IDRWDT,0),U,5),SPEC=SITE_";"_$P(^LAB(61,SITE,0),U)
S TNM=TEST_";"_$S($L($P(^LAB(60,TEST,0),U))<21:$P(^(0),U),1:$P(^(.1),U))
; S DESCR=$S($D(^LAB(60,TEST,1,SITE,0)):^(0),1:""),THER=$S($L($P(DESCR,U,11,12))>1:1,1:0)
; S UNIT=$P(DESCR,U,7),LO=$S(THER:$P(DESCR,U,11),1:$P(DESCR,U,2)),HI=$S(THER:$P(DESCR,U,12),1:$P(DESCR,U,3))
S UNIT=$P(GMTSLRES,U,5),LO=$P(GMTSLRES,U,3),HI=$P(GMTSLRES,U,4)
; S @("LO="_$S($L(LO):LO,1:"""""")),@("HI="_$S($L(HI):HI,1:""""""))
I $D(^TMP("LRS",$J,GMTSI,IDRWDT)) S GMIDT=IDRWDT+.0001
S GMIDT=IDRWDT
S ^TMP("LRS",$J,GMTSI,GMIDT)=DRWDT_U_$E(SPEC,1,10)_U_TNM_U_RESULT_U_FLAG_U_UNIT_U_LO_U_HI
I $D(^LR(LRDFN,"CH",IDRWDT,1,0)) D
. S COM=0
. F GMI=1:1 S COM=$O(^LR(LRDFN,"CH",IDRWDT,1,COM)) Q:+COM'>0 S ^TMP("LRS",$J,"C",GMIDT,GMI)=^LR(LRDFN,"CH",IDRWDT,1,COM,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRSE 2796 printed Sep 23, 2025@19:34:03 Page 2
GMTSLRSE ; SLC/JER,KER - Selected Lab Test Extract ; 09/21/2001
+1 ;;2.7;Health Summary;**28,36,47,79**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 67 ^LAB(60
+5 ; DBIA 524 ^LAB(61
+6 ; DBIA 525 ^LR(
+7 ;
XTRCT ; Extract Selected Lab Test
+1 ;
+2 ; Call with LRDFN lab patient
+3 ; GMTS1 begin date
+4 ; GMTS2 end date
+5 ; MAX occurence limit
+6 ; SEX "M" or "F"
+7 ; TEST IFN to ^LAB(60)
+8 ; RWIDTH optional
+9 ;
+10 ; Returns ^TMP("LRS",$J,GMTSI,IDRWDT)=
+11 ; DRWDT^SPEC^TEST^RESULT^FLAG^UNIT^LO^HI
+12 ;
+13 ; Where GMTSI=Order (1 to MAX)
+14 ; IDRWDT=9999999-Draw Date/time
+15 ; DRWDT=Draw Date/Time (internal)
+16 ; SPEC=Specimen (int;ext)
+17 ; TEST=Test (int;ext)
+18 ; RESULT=Numeric Result
+19 ; FLAG=Reference flag (H,*H,L,*L)
+20 ; UNIT=Unit of measure (ext)
+21 ; LO=Reference/Therapeutic Lower bound
+22 ; HI=Ref/Ther Upper Bound
+23 ;
+24 NEW CNT,AGE,COM,GMI,X
KILL ^TMP("LRS",$JOB,GMTSI)
IF $SELECT("BO"'[$PIECE(^LAB(60,TEST,0),U,3):1,1:0)
QUIT
+25 DO DEM^GMTSU
SET AGE=GMTSAGE
SET CNT=0
if $PIECE(^LAB(60,TEST,0),U,4)="CH"
DO CHEM
+26 QUIT
CHEM ; Gets all Chemistry tests w/in time/occurrence constraints
+1 NEW PTR,IDRWDT
SET PTR=+$PIECE($PIECE(^LAB(60,+TEST,0),U,5),";",2)
SET IDRWDT=GMTS1
+2 FOR
SET IDRWDT=$ORDER(^LR(LRDFN,"CH",IDRWDT))
if 'IDRWDT!(IDRWDT>GMTS2)!(CNT'<MAX)
QUIT
IF $PIECE(^(IDRWDT,0),U,3)
IF ($DATA(^(PTR)))
SET CNT=CNT+1
if CNT'>MAX
DO CHSET
+3 QUIT
CHSET ; Sets Chemistry locals for printing
+1 NEW RESULT,FLAG,DRWDT,SITE,SPEC,TNM,DESCR,THER,UNIT,HI,LO,GMIDT,GMTSLRES
+2 SET GMTSLRES=$$TSTRES^LRRPU(LRDFN,"CH",IDRWDT,PTR)
+3 ; S RESULT=$P(^LR(LRDFN,"CH",IDRWDT,PTR),U),FLAG=$P(^(PTR),U,2),DRWDT=9999999-IDRWDT
+4 SET RESULT=$PIECE(GMTSLRES,U,1)
SET FLAG=$PIECE(GMTSLRES,U,2)
SET DRWDT=9999999-IDRWDT
+5 SET RESULT=$$RESULT^GMTSLRCE(TEST,RESULT,$GET(RWIDTH))
+6 SET X=DRWDT
DO REGDTM4^GMTSU
SET DRWDT=X
KILL X
+7 SET SITE=$PIECE(^LR(LRDFN,"CH",IDRWDT,0),U,5)
SET SPEC=SITE_";"_$PIECE(^LAB(61,SITE,0),U)
+8 SET TNM=TEST_";"_$SELECT($LENGTH($PIECE(^LAB(60,TEST,0),U))<21:$PIECE(^(0),U),1:$PIECE(^(.1),U))
+9 ; S DESCR=$S($D(^LAB(60,TEST,1,SITE,0)):^(0),1:""),THER=$S($L($P(DESCR,U,11,12))>1:1,1:0)
+10 ; S UNIT=$P(DESCR,U,7),LO=$S(THER:$P(DESCR,U,11),1:$P(DESCR,U,2)),HI=$S(THER:$P(DESCR,U,12),1:$P(DESCR,U,3))
+11 SET UNIT=$PIECE(GMTSLRES,U,5)
SET LO=$PIECE(GMTSLRES,U,3)
SET HI=$PIECE(GMTSLRES,U,4)
+12 ; S @("LO="_$S($L(LO):LO,1:"""""")),@("HI="_$S($L(HI):HI,1:""""""))
+13 IF $DATA(^TMP("LRS",$JOB,GMTSI,IDRWDT))
SET GMIDT=IDRWDT+.0001
+14 SET GMIDT=IDRWDT
+15 SET ^TMP("LRS",$JOB,GMTSI,GMIDT)=DRWDT_U_$EXTRACT(SPEC,1,10)_U_TNM_U_RESULT_U_FLAG_U_UNIT_U_LO_U_HI
+16 IF $DATA(^LR(LRDFN,"CH",IDRWDT,1,0))
Begin DoDot:1
+17 SET COM=0
+18 FOR GMI=1:1
SET COM=$ORDER(^LR(LRDFN,"CH",IDRWDT,1,COM))
if +COM'>0
QUIT
SET ^TMP("LRS",$JOB,"C",GMIDT,GMI)=^LR(LRDFN,"CH",IDRWDT,1,COM,0)
End DoDot:1
+19 QUIT
