GMTSLRSC ; SLC/JER,KER - Sel Cum Lab Comp w/Sel Items ; 01/06/2003
;;2.7;Health Summary;**28,47,58**;Oct 20, 1995
;
; External References
; DBIA 10035 ^DPT(
; DBIA 67 ^LAB(60
; DBIA 525 ^LR(
;
MAIN ; Selected Cumulative Lab w/Selection Items
N GMTSI,LRDFN,MAX,TEST,RWIDTH,GMCMNT,COMMNBR,GMCOM,TAB
S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999) Q:'$D(^DPT(DFN,"LR"))
Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR") Q:'$D(^LR(LRDFN)) Q:'$O(GMTSEG(GMTSEGN,60,0))
S RWIDTH=4,GMTSI=0 F S GMTSI=$O(GMTSEG(GMTSEGN,60,GMTSI)) Q:GMTSI'>0 D Q:$D(GMTSQIT)
. S TEST=GMTSEG(GMTSEGN,60,GMTSI) D ^GMTSLRSE
Q:'$D(^TMP("LRS",$J)) S GMCMNT=$S($P($G(^GMT(142.99,1,0)),U,3)="Y":1,1:0),COMMNBR=0
F D DISPLAY Q:$O(^TMP("LRS",$J,0))'>0 Q:$D(GMTSQIT)
I GMCMNT,'$D(GMTSQIT) D WRTCOMM
K ^TMP("LRS",$J),^TMP("LRSR",$J)
Q
DISPLAY ; Displays up to 7 tests across page
N GMC,GMN,GMI,GMW,GMX,HDR,TST,IT,IX,MORE,RES
D INVRT Q:$D(GMTSQIT) S IT="" F GMI=0:1:6 S IT=$O(^TMP("LRS",$J,IT)) Q:'IT D
. S IX="" F S IX=$O(^(IT,IX)) Q:IX'>0 D
. . S TST=+$P(^(IX),U,3),HDR(GMI)=$S(TST'="":$E($P($G(^LAB(60,TST,.1)),U),1,7),1:"")
. . K ^TMP("LRS",$J,IT)
D WRTHDR S RES=$$RES,MORE=$S(+($G(RES))>+($G(MAX)):1,1:0)
S IX="" F GMW=1:1:MAX S IX=$O(^TMP("LRSR",$J,IX)) Q:+IX'>0 D Q:$D(GMTSQIT)
. D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG WRTHDR
. S IT="" F GMI=0:1 S IT=$O(^TMP("LRSR",$J,IX,IT)) Q:IT="" D Q:$D(GMTSQIT)
. . D WRT I '$O(^TMP("LRSR",$J,IX,IT)) W !
I '$D(GMTSOBJ),+($G(MORE)) D
. D CKP^GMTSUP Q:$D(GMTSQIT)
. W $C(7),!?10,"** Additional Results available outside occurrence limit **",!
K ^TMP("LRSR",$J) W:$D(^TMP("LRS",$J)) !
Q
WRTHDR ; Writes Column Header
N GMI
D CKP^GMTSUP Q:$D(GMTSQIT) W "Collection DT"
W ?19,$S(+$G(GMCMNT):" ",1:""),"Spec"
F GMI=0:1:6 D CKP^GMTSUP Q:'$D(HDR(GMI))!($D(GMTSQIT)) W ?(((8*GMI+25)+(7-$L(HDR(GMI))\2))),$E(HDR(GMI),1,7)
D CKP^GMTSUP Q:$D(GMTSQIT) W !
I '$D(GMTSOBJ) D CKP^GMTSUP Q:$D(GMTSQIT) W !
Q
WRT ; Writes the Lab Record
S GMX=^TMP("LRSR",$J,IX,IT),TAB=$P(GMX,U)
I GMI=0!(GMTSNPG) D
. I +$G(GMCMNT),$D(^TMP("LRS",$J,"C",IX))>0,$D(GMCOM("DT",IX))'>0,COMMNBR<26 D
. . S GMLTR=$C(97+COMMNBR) S COMMNBR=COMMNBR+1
. . S GMCOM("DT",IX)=GMLTR,GMCOM("LTR",GMLTR)=IX
. I +$G(GMCMNT) D Q
. . W $E($G(GMCOM("DT",IX)),1),?2,$P(GMX,U,2),?19,$E($P($P(GMX,U,3),";",2),1,5)
. W $P(GMX,U,2),?19,$E($P($P(GMX,U,3),";",2),1,5)
W ?(8*TAB+25),$P(GMX,U,4)," ",$P(GMX,U,5)
Q
WRTCOMM ; Writes the lab Comments
N GMLTR,GMLINE
Q:$D(GMCOM)'>0
D CKP^GMTSUP Q:$D(GMTSQIT) W "COMMENTS:",!
S GMLTR=""
F S GMLTR=$O(GMCOM("LTR",GMLTR)) Q:GMLTR']"" D Q:$D(GMTSQIT)
. S IX=$G(GMCOM("LTR",GMLTR)),GMLINE=0
. F S GMLINE=$O(^TMP("LRS",$J,"C",+IX,GMLINE)) Q:GMLINE'>0 D Q:$D(GMTSQIT)
. . D CKP^GMTSUP Q:$D(GMTSQIT) I GMTSNPG W "COMMENTS:",!
. . W:GMLINE=1!GMTSNPG GMLTR_"."
. . W ?3,$G(^TMP("LRS",$J,"C",+IX,GMLINE)),!
Q
;
RES(X) ; Results
N NN,NC S X=0,NN="^TMP(""LRSR"","_$J_")",NC="^TMP(""LRSR"","_$J_","
F S NN=$Q(@NN) Q:NN=""!(NN'[NC) S X=X+1
Q X
INVRT ; Inverts Global Array
;
; From: ^TMP("LRS",$J,IT,IX)=CDT^SPC^TNM^RSLT^FLAG^UNIT^LO^HI
; To: ^TMP("LRSR",$J,IX,IT)=GMI,CDT,SPC,RSLT,FLAG
;
N GMI,IT,IX
S IT=""
F GMI=0:1:6 S IT=$O(^TMP("LRS",$J,IT)) Q:IT'>0 D
. S IX="" F S IX=$O(^TMP("LRS",$J,IT,IX)) Q:IX="" D
. . S ^TMP("LRSR",$J,IX,IT)=GMI_U_$P(^TMP("LRS",$J,IT,IX),U,1,2)_U_$P(^TMP("LRS",$J,IT,IX),U,4,5)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRSC 3561 printed Nov 22, 2024@17:08:05 Page 2
GMTSLRSC ; SLC/JER,KER - Sel Cum Lab Comp w/Sel Items ; 01/06/2003
+1 ;;2.7;Health Summary;**28,47,58**;Oct 20, 1995
+2 ;
+3 ; External References
+4 ; DBIA 10035 ^DPT(
+5 ; DBIA 67 ^LAB(60
+6 ; DBIA 525 ^LR(
+7 ;
MAIN ; Selected Cumulative Lab w/Selection Items
+1 NEW GMTSI,LRDFN,MAX,TEST,RWIDTH,GMCMNT,COMMNBR,GMCOM,TAB
+2 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:999)
if '$DATA(^DPT(DFN,"LR"))
QUIT
+3 if '$DATA(^DPT(DFN,"LR"))
QUIT
SET LRDFN=+^DPT(DFN,"LR")
if '$DATA(^LR(LRDFN))
QUIT
if '$ORDER(GMTSEG(GMTSEGN,60,0))
QUIT
+4 SET RWIDTH=4
SET GMTSI=0
FOR
SET GMTSI=$ORDER(GMTSEG(GMTSEGN,60,GMTSI))
if GMTSI'>0
QUIT
Begin DoDot:1
+5 SET TEST=GMTSEG(GMTSEGN,60,GMTSI)
DO ^GMTSLRSE
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+6 if '$DATA(^TMP("LRS",$JOB))
QUIT
SET GMCMNT=$SELECT($PIECE($GET(^GMT(142.99,1,0)),U,3)="Y":1,1:0)
SET COMMNBR=0
+7 FOR
DO DISPLAY
if $ORDER(^TMP("LRS",$JOB,0))'>0
QUIT
if $DATA(GMTSQIT)
QUIT
+8 IF GMCMNT
IF '$DATA(GMTSQIT)
DO WRTCOMM
+9 KILL ^TMP("LRS",$JOB),^TMP("LRSR",$JOB)
+10 QUIT
DISPLAY ; Displays up to 7 tests across page
+1 NEW GMC,GMN,GMI,GMW,GMX,HDR,TST,IT,IX,MORE,RES
+2 DO INVRT
if $DATA(GMTSQIT)
QUIT
SET IT=""
FOR GMI=0:1:6
SET IT=$ORDER(^TMP("LRS",$JOB,IT))
if 'IT
QUIT
Begin DoDot:1
+3 SET IX=""
FOR
SET IX=$ORDER(^(IT,IX))
if IX'>0
QUIT
Begin DoDot:2
+4 SET TST=+$PIECE(^(IX),U,3)
SET HDR(GMI)=$SELECT(TST'="":$EXTRACT($PIECE($GET(^LAB(60,TST,.1)),U),1,7),1:"")
+5 KILL ^TMP("LRS",$JOB,IT)
End DoDot:2
End DoDot:1
+6 DO WRTHDR
SET RES=$$RES
SET MORE=$SELECT(+($GET(RES))>+($GET(MAX)):1,1:0)
+7 SET IX=""
FOR GMW=1:1:MAX
SET IX=$ORDER(^TMP("LRSR",$JOB,IX))
if +IX'>0
QUIT
Begin DoDot:1
+8 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
if GMTSNPG
DO WRTHDR
+9 SET IT=""
FOR GMI=0:1
SET IT=$ORDER(^TMP("LRSR",$JOB,IX,IT))
if IT=""
QUIT
Begin DoDot:2
+10 DO WRT
IF '$ORDER(^TMP("LRSR",$JOB,IX,IT))
WRITE !
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+11 IF '$DATA(GMTSOBJ)
IF +($GET(MORE))
Begin DoDot:1
+12 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
+13 WRITE $CHAR(7),!?10,"** Additional Results available outside occurrence limit **",!
End DoDot:1
+14 KILL ^TMP("LRSR",$JOB)
if $DATA(^TMP("LRS",$JOB))
WRITE !
+15 QUIT
WRTHDR ; Writes Column Header
+1 NEW GMI
+2 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE "Collection DT"
+3 WRITE ?19,$SELECT(+$GET(GMCMNT):" ",1:""),"Spec"
+4 FOR GMI=0:1:6
DO CKP^GMTSUP
if '$DATA(HDR(GMI))!($DATA(GMTSQIT))
QUIT
WRITE ?(((8*GMI+25)+(7-$LENGTH(HDR(GMI))\2))),$EXTRACT(HDR(GMI),1,7)
+5 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+6 IF '$DATA(GMTSOBJ)
DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE !
+7 QUIT
WRT ; Writes the Lab Record
+1 SET GMX=^TMP("LRSR",$JOB,IX,IT)
SET TAB=$PIECE(GMX,U)
+2 IF GMI=0!(GMTSNPG)
Begin DoDot:1
+3 IF +$GET(GMCMNT)
IF $DATA(^TMP("LRS",$JOB,"C",IX))>0
IF $DATA(GMCOM("DT",IX))'>0
IF COMMNBR<26
Begin DoDot:2
+4 SET GMLTR=$CHAR(97+COMMNBR)
SET COMMNBR=COMMNBR+1
+5 SET GMCOM("DT",IX)=GMLTR
SET GMCOM("LTR",GMLTR)=IX
End DoDot:2
+6 IF +$GET(GMCMNT)
Begin DoDot:2
+7 WRITE $EXTRACT($GET(GMCOM("DT",IX)),1),?2,$PIECE(GMX,U,2),?19,$EXTRACT($PIECE($PIECE(GMX,U,3),";",2),1,5)
End DoDot:2
QUIT
+8 WRITE $PIECE(GMX,U,2),?19,$EXTRACT($PIECE($PIECE(GMX,U,3),";",2),1,5)
End DoDot:1
+9 WRITE ?(8*TAB+25),$PIECE(GMX,U,4)," ",$PIECE(GMX,U,5)
+10 QUIT
WRTCOMM ; Writes the lab Comments
+1 NEW GMLTR,GMLINE
+2 if $DATA(GMCOM)'>0
QUIT
+3 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
WRITE "COMMENTS:",!
+4 SET GMLTR=""
+5 FOR
SET GMLTR=$ORDER(GMCOM("LTR",GMLTR))
if GMLTR']""
QUIT
Begin DoDot:1
+6 SET IX=$GET(GMCOM("LTR",GMLTR))
SET GMLINE=0
+7 FOR
SET GMLINE=$ORDER(^TMP("LRS",$JOB,"C",+IX,GMLINE))
if GMLINE'>0
QUIT
Begin DoDot:2
+8 DO CKP^GMTSUP
if $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE "COMMENTS:",!
+9 if GMLINE=1!GMTSNPG
WRITE GMLTR_"."
+10 WRITE ?3,$GET(^TMP("LRS",$JOB,"C",+IX,GMLINE)),!
End DoDot:2
if $DATA(GMTSQIT)
QUIT
End DoDot:1
if $DATA(GMTSQIT)
QUIT
+11 QUIT
+12 ;
RES(X) ; Results
+1 NEW NN,NC
SET X=0
SET NN="^TMP(""LRSR"","_$JOB_")"
SET NC="^TMP(""LRSR"","_$JOB_","
+2 FOR
SET NN=$QUERY(@NN)
if NN=""!(NN'[NC)
QUIT
SET X=X+1
+3 QUIT X
INVRT ; Inverts Global Array
+1 ;
+2 ; From: ^TMP("LRS",$J,IT,IX)=CDT^SPC^TNM^RSLT^FLAG^UNIT^LO^HI
+3 ; To: ^TMP("LRSR",$J,IX,IT)=GMI,CDT,SPC,RSLT,FLAG
+4 ;
+5 NEW GMI,IT,IX
+6 SET IT=""
+7 FOR GMI=0:1:6
SET IT=$ORDER(^TMP("LRS",$JOB,IT))
if IT'>0
QUIT
Begin DoDot:1
+8 SET IX=""
FOR
SET IX=$ORDER(^TMP("LRS",$JOB,IT,IX))
if IX=""
QUIT
Begin DoDot:2
+9 SET ^TMP("LRSR",$JOB,IX,IT)=GMI_U_$PIECE(^TMP("LRS",$JOB,IT,IX),U,1,2)_U_$PIECE(^TMP("LRS",$JOB,IT,IX),U,4,5)
End DoDot:2
End DoDot:1
+10 QUIT
