GMTSLRCE ; SLC/JER,KER - Chemistry Extract Routine ; 08/27/2002
;;2.7;Health Summary;**18,28,29,56**;Oct 20, 1995
;
; External References
; DBIA 67 ^LAB(60
; DBIA 524 ^LAB(61
; DBIA 525 ^LR(
; DBIA 10103 $$FMTHL7^XLFDT
;
XTRCT ; Extract
;
; Call with LRDFN, GMTS1, GMTS2,
; MAX (#occurrences) and SEX (M or F)
;
N IDT,CNT,AGE D:'$D(GMTSAGE) DEM^GMTSU S AGE=GMTSAGE K ^TMP("LRC",$J)
S IDT=GMTS1,CNT=0 F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT=""!(IDT>GMTS2) D:CNT'>MAX CHSET
Q
CHSET ; Sets Chemistry locals for printing
N CDT,SITE,SPEC,PTR,ISVALID,GMI,ACC,LOC,COM,RDT,SNOMED
S ISVALID=$P(^LR(LRDFN,"CH",IDT,0),U,3) Q:ISVALID="" S SNOMED=""
S CDT=+^LR(LRDFN,"CH",IDT,0),SITE=$P(^(0),U,5),SPEC=$P(^LAB(61,SITE,0),U),SNOMED=$P(^(0),U,2),CNT=CNT+1
I $D(EXPAND) D
. S SPEC=SNOMED_";"_SPEC,RDT=$P(^LR(LRDFN,"CH",IDT,0),U,3)
. S ACC=$P(^(0),U,6),ACC=$P(ACC," ",2,3)_" "_$P(ACC," ")
. S LOC=$P(^(0),U,11)
. S RDT=$$FMTHL7^XLFDT(RDT)
S X=CDT D REGDTM4^GMTSU:'$D(EXPAND)
S:$D(EXPAND) X=$$FMTHL7^XLFDT(X) S CDT=X K X
S PTR=1 F S PTR=$O(^LR(LRDFN,"CH",IDT,PTR)) Q:PTR<1 D NXTST
I $D(^LR(LRDFN,"CH",IDT,1,0)),($D(^TMP("LRC",$J,IDT))) D
. S COM=0 F GMI=1:1 S COM=$O(^LR(LRDFN,"CH",IDT,1,COM)) Q:+COM'>0 S ^TMP("LRC",$J,IDT,"C",GMI)=^LR(LRDFN,"CH",IDT,1,COM,0)
Q
NXTST ; Visit next node in ^(PTR) subtree
N RESULT,FLAG,TEST,GMPC,GMSQN,TNM,DESCR,THER,UNIT,HI,LO,CIS
S RESULT=$P(^LR(LRDFN,"CH",IDT,PTR),U),FLAG=$P(^(PTR),U,2),CIS=""
I $D(EXPAND),(FLAG["*") S FLAG=$S(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
S TEST=$O(^LAB(60,"C","CH;"_PTR_";1",0)) Q:TEST'>0
S TNM=$S($L($P(^LAB(60,TEST,0),U))<19:$P(^(0),U),1:$P(^(.1),U))
; Quit if Test Type is neither "Output" or "Both"
I $S("BO"'[$P(^LAB(60,TEST,0),U,3):1,1:0) Q
S GMSQN=$S($P($G(^LAB(60,TEST,.1)),U,6):$P($G(^(.1)),U,6),1:PTR/1000000)
I $D(^LAB(60,TEST,10)) S CIS=^(10)
I $D(EXPAND),'$L(CIS) Q
I $D(EXPAND) S TNM=CIS_";"_TNM
; Execute Print Code from file 60 to evaluate RESULT
S RESULT=$$RESULT(TEST,RESULT,$G(RWIDTH))
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 @("LO="_$S($L(LO):LO,1:"""""")),@("HI="_$S($L(HI):HI,1:""""""))
I $D(EXPAND),'$L(FLAG),(+$G(HI)'<+$G(RESULT)),(+$G(LO)'>+$G(RESULT)) S FLAG="N"
F Q:'$D(^TMP("LRC",$J,IDT,GMSQN)) Q:TEST=+^(GMSQN) S GMSQN=GMSQN+1
Q:$D(^TMP("LRC",$J,IDT,GMSQN))
S ^TMP("LRC",$J,IDT,GMSQN)=CDT_U_SPEC_U_TNM_U_RESULT_U_FLAG_U_UNIT_U_LO_U_HI
I $D(EXPAND) D XPND
Q
XPND ; Appends additional data if required
S ^TMP("LRC",$J,IDT,GMSQN)=^TMP("LRC",$J,IDT,GMSQN)_U_ACC_U_RDT_U_LOC
Q
;
RESULT(TEST,RESULT,LRCW) ; Convert result to external format
;
; Where
; TEST=Test ptr to file 60
; RESULT=Test result
; LRCW=Optional width of variable. Default is 0
N X,X1
I +$G(LRCW)'>0 S LRCW=0
S X1=$P($G(^LAB(60,TEST,.1)),"^",3),X1=$S($L(X1):X1,1:"$J(X,LRCW)"),X=RESULT,@("X="_X1)
Q X
GMTSLRCE ; SLC/JER,KER - Chemistry Extract Routine ; 08/27/2002
+1 ;;2.7;Health Summary;**18,28,29,56**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 67 ^LAB(60
+5 ; DBIA 524 ^LAB(61
+6 ; DBIA 525 ^LR(
+7 ; DBIA 10103 $$FMTHL7^XLFDT
+8 ;
XTRCT ; Extract
+1 ;
+2 ; Call with LRDFN, GMTS1, GMTS2,
+3 ; MAX (#occurrences) and SEX (M or F)
+4 ;
+5 NEW IDT,CNT,AGE
IF '$DATA(GMTSAGE)
DO DEM^GMTSU
SET AGE=GMTSAGE
KILL ^TMP("LRC",$JOB)
+6 SET IDT=GMTS1
SET CNT=0
FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT))
IF IDT=""!(IDT>GMTS2)
QUIT
IF CNT'>MAX
DO CHSET
+7 QUIT
CHSET ; Sets Chemistry locals for printing
+1 NEW CDT,SITE,SPEC,PTR,ISVALID,GMI,ACC,LOC,COM,RDT,SNOMED
+2 SET ISVALID=$PIECE(^LR(LRDFN,"CH",IDT,0),U,3)
IF ISVALID=""
QUIT
SET SNOMED=""
+3 SET CDT=+^LR(LRDFN,"CH",IDT,0)
SET SITE=$PIECE(^(0),U,5)
SET SPEC=$PIECE(^LAB(61,SITE,0),U)
SET SNOMED=$PIECE(^(0),U,2)
SET CNT=CNT+1
+4 IF $DATA(EXPAND)
Begin DoDot:1
+5 SET SPEC=SNOMED_";"_SPEC
SET RDT=$PIECE(^LR(LRDFN,"CH",IDT,0),U,3)
+6 SET ACC=$PIECE(^(0),U,6)
SET ACC=$PIECE(ACC," ",2,3)_" "_$PIECE(ACC," ")
+7 SET LOC=$PIECE(^(0),U,11)
+8 SET RDT=$$FMTHL7^XLFDT(RDT)
End DoDot:1
+9 SET X=CDT
IF '$DATA(EXPAND)
DO REGDTM4^GMTSU
+10 IF $DATA(EXPAND)
SET X=$$FMTHL7^XLFDT(X)
SET CDT=X
KILL X
+11 SET PTR=1
FOR
SET PTR=$ORDER(^LR(LRDFN,"CH",IDT,PTR))
IF PTR<1
QUIT
DO NXTST
+12 IF $DATA(^LR(LRDFN,"CH",IDT,1,0))
IF ($DATA(^TMP("LRC",$JOB,IDT)))
Begin DoDot:1
+13 SET COM=0
FOR GMI=1:1
SET COM=$ORDER(^LR(LRDFN,"CH",IDT,1,COM))
IF +COM'>0
QUIT
SET ^TMP("LRC",$JOB,IDT,"C",GMI)=^LR(LRDFN,"CH",IDT,1,COM,0)
End DoDot:1
+14 QUIT
NXTST ; Visit next node in ^(PTR) subtree
+1 NEW RESULT,FLAG,TEST,GMPC,GMSQN,TNM,DESCR,THER,UNIT,HI,LO,CIS
+2 SET RESULT=$PIECE(^LR(LRDFN,"CH",IDT,PTR),U)
SET FLAG=$PIECE(^(PTR),U,2)
SET CIS=""
+3 IF $DATA(EXPAND)
IF (FLAG["*")
SET FLAG=$SELECT(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
+4 SET TEST=$ORDER(^LAB(60,"C","CH;"_PTR_";1",0))
IF TEST'>0
QUIT
+5 SET TNM=$SELECT($LENGTH($PIECE(^LAB(60,TEST,0),U))<19:$PIECE(^(0),U),1:$PIECE(^(.1),U))
+6 ; Quit if Test Type is neither "Output" or "Both"
+7 IF $SELECT("BO"'[$PIECE(^LAB(60,TEST,0),U,3):1,1:0)
QUIT
+8 SET GMSQN=$SELECT($PIECE($GET(^LAB(60,TEST,.1)),U,6):$PIECE($GET(^(.1)),U,6),1:PTR/1000000)
+9 IF $DATA(^LAB(60,TEST,10))
SET CIS=^(10)
+10 IF $DATA(EXPAND)
IF '$LENGTH(CIS)
QUIT
+11 IF $DATA(EXPAND)
SET TNM=CIS_";"_TNM
+12 ; Execute Print Code from file 60 to evaluate RESULT
+13 SET RESULT=$$RESULT(TEST,RESULT,$GET(RWIDTH))
+14 SET DESCR=$SELECT($DATA(^LAB(60,TEST,1,SITE,0)):^(0),1:"")
SET THER=$SELECT($LENGTH($PIECE(DESCR,U,11,12))>1:1,1:0)
+15 SET UNIT=$PIECE(DESCR,U,7)
SET LO=$SELECT(THER:$PIECE(DESCR,U,11),1:$PIECE(DESCR,U,2))
SET HI=$SELECT(THER:$PIECE(DESCR,U,12),1:$PIECE(DESCR,U,3))
+16 SET @("LO="_$SELECT($LENGTH(LO):LO,1:""""""))
SET @("HI="_$SELECT($LENGTH(HI):HI,1:""""""))
+17 IF $DATA(EXPAND)
IF '$LENGTH(FLAG)
IF (+$GET(HI)'<+$GET(RESULT))
IF (+$GET(LO)'>+$GET(RESULT))
SET FLAG="N"
+18 FOR
IF '$DATA(^TMP("LRC",$JOB,IDT,GMSQN))
QUIT
IF TEST=+^(GMSQN)
QUIT
SET GMSQN=GMSQN+1
+19 IF $DATA(^TMP("LRC",$JOB,IDT,GMSQN))
QUIT
+20 SET ^TMP("LRC",$JOB,IDT,GMSQN)=CDT_U_SPEC_U_TNM_U_RESULT_U_FLAG_U_UNIT_U_LO_U_HI
+21 IF $DATA(EXPAND)
DO XPND
+22 QUIT
XPND ; Appends additional data if required
+1 SET ^TMP("LRC",$JOB,IDT,GMSQN)=^TMP("LRC",$JOB,IDT,GMSQN)_U_ACC_U_RDT_U_LOC
+2 QUIT
+3 ;
RESULT(TEST,RESULT,LRCW) ; Convert result to external format
+1 ;
+2 ; Where
+3 ; TEST=Test ptr to file 60
+4 ; RESULT=Test result
+5 ; LRCW=Optional width of variable. Default is 0
+6 NEW X,X1
+7 IF +$GET(LRCW)'>0
SET LRCW=0
+8 SET X1=$PIECE($GET(^LAB(60,TEST,.1)),"^",3)
SET X1=$SELECT($LENGTH(X1):X1,1:"$J(X,LRCW)")
SET X=RESULT
SET @("X="_X1)
+9 QUIT X
