Routine: GMTSLRS

GMTSLRS ; SLC/JER,KER - Sel Lab Component w/Selection Items ; 01/06/2003

 ;;2.7;Health Summary;**16,28,47,58,88**;Oct 20, 1995;Build 23

 ; External References

 ;    DBIA    67  ^LAB(60

 ;    DBIA   525  ^LR( all fields

 ;    DBIA 10035  ^DPT( field 63 Read w/Fileman

 ;    DBIA  2056  $$GET1^DIQ (file 2)

MAIN ; Selected Lab w/Selection Items

 N GMTSI,GMW,GMX,LRDFN,MAX,IT,IX,PTEST,TEST,BEGIN,END,CNT,RWIDTH,GMLINE,GMCMNT,GMCFLAG

 S RWIDTH=8,LRDFN=+($$GET1^DIQ(2,(+($G(DFN))_","),63,"I")) Q:+LRDFN=0  Q:'$D(^LR(LRDFN))

 S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:999) Q:'$O(GMTSEG(GMTSEGN,60,0))

 S GMCMNT=$S($P($G(^GMT(142.99,1,0)),U,3)="Y":1,1:0)

 S GMTSI=0 F  S GMTSI=$O(GMTSEG(GMTSEGN,60,GMTSI)) Q:GMTSI'>0  D  Q:$D(GMTSQIT)

 . S (PTEST,TEST)=GMTSEG(GMTSEGN,60,GMTSI)

 . D @$S($L($P(^LAB(60,TEST,0),U,5)):"^GMTSLRSE",1:"PANEL")

 Q:'$D(^TMP("LRS",$J))  D WRTHDR Q:$D(GMTSQIT)

 S IT=0 F  S IT=$O(^TMP("LRS",$J,IT)) Q:+IT'>0  D  Q:$D(GMTSQIT)

 . S IX="" F  S IX=$O(^TMP("LRS",$J,IT,IX)) Q:'IX!(IX>GMTS2)  D  Q:$D(GMTSQIT)

 . . S GMX=^TMP("LRS",$J,IT,IX) D WRT

 I +$G(GMCFLAG) D

 . D CKP^GMTSUP Q:$D(GMTSQIT)  W !

 . D CKP^GMTSUP Q:$D(GMTSQIT)

 . W "!!  Indicates COMMENTS AVAILABLE...Refer to Interim Lab Report.",!

 K ^TMP("LRS",$J)

PANEL ; Visits "PANEL" multiple to get pointers to atomic tests

 N TEST,GMW,INDX

 S INDX=0 F  S INDX=$O(^LAB(60,PTEST,2,INDX)) Q:'INDX  S TEST=^(INDX,0) S:'$L($P(^LAB(60,TEST,0),U,5)) PTEST=TEST D @$S($L($P(^LAB(60,TEST,0),U,5)):"^GMTSLRSE",1:"PANEL")

WRTHDR ; Prints columnar header

 D CKP^GMTSUP Q:$D(GMTSQIT)  W "Collection DT",?18,"Specimen"

 W ?29,"Test Name",?48,"Result",?58,"Units",?70,"Ref Range",!

 W:'$D(GMTSOBJ) !

WRT ; Writes the Lab Record

 ; VMP/RJT - Lab Ref Range update

 N ISNEG,REF,TAB D CKP^GMTSUP Q:$D(GMTSQIT)  D

 . D:GMTSNPG WRTHDR N GMTSI

 . W $P(GMX,U),?18,$P($P(GMX,U,2),";",2)

 . I $D(^TMP("LRS",$J,"C",IX))>9,'+$G(GMCMNT) W ?24,"!! " S GMCFLAG=1

 . S GMTSI=$P(GMX,U,8),ISNEG=0 S:GMTSI="NEGATIVE" GMTSI="NEG",ISNEG=1

 . W ?29,$E($P($P(GMX,U,3),";",2),1,17),?46,$P(GMX,U,4)," ",$P(GMX,U,5)

 . ; VM/RJT - Lab Ref Range update

 . ;W ?58,$P(GMX,U,6),?68,$J($P(GMX,U,7),4),?73,"-",?74,$J(GMTSI,4),!

 . I ((ISNEG=1)!($P(GMX,U,7)="NEGATIVE")) W ?58,$P(GMX,U,6),?67,$J("NEG",12),! Q

 . S REF=$$EN^LRLRRVF($P(GMX,U,7),$G(GMTSI))

 . S TAB=67+($S(REF?1A.E:2,1:(8-$F(REF,"-")))) S:TAB<67 TAB=67

 . I (TAB>72)&($L(REF)>5) S TAB=67+((13-($L(REF))/2))

 . I ($L(REF)>12),($L(REF)<15) S TAB=80-($L(REF))

 . W ?58,$P(GMX,U,6),?TAB,REF,!

 I +$G(GMCMNT),$D(^TMP("LRS",$J,"C",IX))>9,'$D(^TMP("LRS",$J,+$O(^TMP("LRS",$J,IT)),IX)) D  Q

 . S GMLINE=0

 . F  S GMLINE=$O(^TMP("LRS",$J,"C",IX,GMLINE)) Q:GMLINE'>0  D

 . . D CKP^GMTSUP Q:$D(GMTSQIT)

 . . W "Comment: ",^TMP("LRS",$J,"C",IX,GMLINE),!

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRS   2833     printed  Feb 18, 2025@23:24:18                                                                                                                                                                                                     Page 2

GMTSLRS   ; SLC/JER,KER - Sel Lab Component w/Selection Items ; 01/06/2003

 +1       ;;2.7;Health Summary;**16,28,47,58,88**;Oct 20, 1995;Build 23

 +2       ;

 +3       ; External References

 +4       ;    DBIA    67  ^LAB(60

 +5       ;    DBIA   525  ^LR( all fields

 +6       ;    DBIA 10035  ^DPT( field 63 Read w/Fileman

 +7       ;    DBIA  2056  $$GET1^DIQ (file 2)

 +8       ;

MAIN      ; Selected Lab w/Selection Items

 +1        NEW GMTSI,GMW,GMX,LRDFN,MAX,IT,IX,PTEST,TEST,BEGIN,END,CNT,RWIDTH,GMLINE,GMCMNT,GMCFLAG

 +2        SET RWIDTH=8

           SET LRDFN=+($$GET1^DIQ(2,(+($GET(DFN))_","),63,"I"))

           if +LRDFN=0

               QUIT

           if '$DATA(^LR(LRDFN))

               QUIT

 +3        SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:999)

           if '$ORDER(GMTSEG(GMTSEGN,60,0))

               QUIT

 +4        SET GMCMNT=$SELECT($PIECE($GET(^GMT(142.99,1,0)),U,3)="Y":1,1:0)

 +5        SET GMTSI=0

FOR

               SET GMTSI=$ORDER(GMTSEG(GMTSEGN,60,GMTSI))

               if GMTSI'>0

                   QUIT

               Begin DoDot:1

 +6                SET (PTEST,TEST)=GMTSEG(GMTSEGN,60,GMTSI)

 +7                DO @$SELECT($LENGTH($PIECE(^LAB(60,TEST,0),U,5)):"^GMTSLRSE",1:"PANEL")

               End DoDot:1

               if $DATA(GMTSQIT)

                   QUIT

 +8        if '$DATA(^TMP("LRS",$JOB))

               QUIT

           DO WRTHDR

           if $DATA(GMTSQIT)

               QUIT

 +9        SET IT=0

FOR

               SET IT=$ORDER(^TMP("LRS",$JOB,IT))

               if +IT'>0

                   QUIT

               Begin DoDot:1

 +10               SET IX=""

FOR

                       SET IX=$ORDER(^TMP("LRS",$JOB,IT,IX))

                       if 'IX!(IX>GMTS2)

                           QUIT

                       Begin DoDot:2

 +11                       SET GMX=^TMP("LRS",$JOB,IT,IX)

                           DO WRT

                       End DoDot:2

                       if $DATA(GMTSQIT)

                           QUIT

               End DoDot:1

               if $DATA(GMTSQIT)

                   QUIT

 +12       IF +$GET(GMCFLAG)

               Begin DoDot:1

 +13               DO CKP^GMTSUP

                   if $DATA(GMTSQIT)

                       QUIT

                   WRITE !

 +14               DO CKP^GMTSUP

                   if $DATA(GMTSQIT)

                       QUIT

 +15               WRITE "!!  Indicates COMMENTS AVAILABLE...Refer to Interim Lab Report.",!

               End DoDot:1

 +16       KILL ^TMP("LRS",$JOB)

 +17       QUIT

PANEL     ; Visits "PANEL" multiple to get pointers to atomic tests

 +1        NEW TEST,GMW,INDX

 +2        SET INDX=0

FOR

               SET INDX=$ORDER(^LAB(60,PTEST,2,INDX))

               if 'INDX

                   QUIT

               SET TEST=^(INDX,0)

               if '$LENGTH($PIECE(^LAB(60,TEST,0),U,5))

                   SET PTEST=TEST

               DO @$SELECT($LENGTH($PIECE(^LAB(60,TEST,0),U,5)):"^GMTSLRSE",1:"PANEL")

 +3        QUIT

WRTHDR    ; Prints columnar header

 +1        DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

           WRITE "Collection DT",?18,"Specimen"

 +2        WRITE ?29,"Test Name",?48,"Result",?58,"Units",?70,"Ref Range",!

 +3        if '$DATA(GMTSOBJ)

               WRITE !

 +4        QUIT

WRT       ; Writes the Lab Record

 +1       ; VMP/RJT - Lab Ref Range update

 +2        NEW ISNEG,REF,TAB

           DO CKP^GMTSUP

           if $DATA(GMTSQIT)

               QUIT

           Begin DoDot:1

 +3            if GMTSNPG

                   DO WRTHDR

               NEW GMTSI

 +4            WRITE $PIECE(GMX,U),?18,$PIECE($PIECE(GMX,U,2),";",2)

 +5            IF $DATA(^TMP("LRS",$JOB,"C",IX))>9

                   IF '+$GET(GMCMNT)

                       WRITE ?24,"!! "

                       SET GMCFLAG=1

 +6            SET GMTSI=$PIECE(GMX,U,8)

               SET ISNEG=0

               if GMTSI="NEGATIVE"

                   SET GMTSI="NEG"

                   SET ISNEG=1

 +7            WRITE ?29,$EXTRACT($PIECE($PIECE(GMX,U,3),";",2),1,17),?46,$PIECE(GMX,U,4)," ",$PIECE(GMX,U,5)

 +8       ; VM/RJT - Lab Ref Range update

 +9       ;W ?58,$P(GMX,U,6),?68,$J($P(GMX,U,7),4),?73,"-",?74,$J(GMTSI,4),!

 +10           IF ((ISNEG=1)!($PIECE(GMX,U,7)="NEGATIVE"))

                   WRITE ?58,$PIECE(GMX,U,6),?67,$JUSTIFY("NEG",12),!

                   QUIT

 +11           SET REF=$$EN^LRLRRVF($PIECE(GMX,U,7),$GET(GMTSI))

 +12           SET TAB=67+($SELECT(REF?1A.E:2,1:(8-$FIND(REF,"-"))))

               if TAB<67

                   SET TAB=67

 +13           IF (TAB>72)&($LENGTH(REF)>5)

                   SET TAB=67+((13-($LENGTH(REF))/2))

 +14           IF ($LENGTH(REF)>12)

                   IF ($LENGTH(REF)<15)

                       SET TAB=80-($LENGTH(REF))

 +15           WRITE ?58,$PIECE(GMX,U,6),?TAB,REF,!

           End DoDot:1

 +16       IF +$GET(GMCMNT)

               IF $DATA(^TMP("LRS",$JOB,"C",IX))>9

                   IF '$DATA(^TMP("LRS",$JOB,+$ORDER(^TMP("LRS",$JOB,IT)),IX))

                       Begin DoDot:1

 +17                       SET GMLINE=0

 +18                       FOR

                               SET GMLINE=$ORDER(^TMP("LRS",$JOB,"C",IX,GMLINE))

                               if GMLINE'>0

                                   QUIT

                               Begin DoDot:2

 +19                               DO CKP^GMTSUP

                                   if $DATA(GMTSQIT)

                                       QUIT

 +20                               WRITE "Comment: ",^TMP("LRS",$JOB,"C",IX,GMLINE),!

                               End DoDot:2

                       End DoDot:1

                       QUIT

 +21       QUIT

GMTSLRS.m