GMTSLRMB.m

GMTSLRMB ; SLC/JER,KER - Microbiology Component Dvr ; 09/21/2001

 ;;2.7;Health Summary;**25,28,47**;Oct 20, 1995

 ;

 ; External References

 ;    DBIA   525  ^LR( all fields

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

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

 ;                       

MAIN ; Microbioloby Brief

 N IX0,IX,LRDFN,MAX,D1,D2,D3

 S 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)

 S IX=GMTS1 F IX0=1:1:MAX S IX=$O(^LR(LRDFN,"MI",IX)) Q:+IX'>0!(IX>GMTS2)  D CKP^GMTSUP Q:$D(GMTSQIT)  D  Q:$D(GMTSQIT)

 . D ^GMTSLRME I $D(^TMP("LRM",$J)) D

 . . D:IX0>1 CKP^GMTSUP Q:$D(GMTSQIT)  W:IX0>1&'GMTSNPG ! D INTRP

 . K ^TMP("LRM",$J)

 Q

INTRP ; Interprets ^TMP("LRM",$J

 N GMTSJ,GMK,GMW,SMEAR,GMABX

 S (GMTSJ,GMK)=""

 F  S GMTSJ=$O(^TMP("LRM",$J,GMTSJ)) Q:GMTSJ=""!$D(GMTSQIT)  D RDNODE

 Q

RDNODE ; Reads current node of ^TMP("LRM",$J

 Q:GMTSJ="BSTER"

 I GMTSJ=0 D  Q

 . D CKP^GMTSUP Q:$D(GMTSQIT)  W $P($P(^TMP("LRM",$J,GMTSJ),U)," "),?12,$P(^TMP("LRM",$J,GMTSJ),U,3),!

 . D WRTTEST

 S GMK=""

 F  S GMK=$O(^TMP("LRM",$J,GMTSJ,GMK)) Q:GMK=""!$D(GMTSQIT)  D WRTNODE

 I GMTSJ="TB" D  Q:$D(GMTSQIT)

 . I $P(^TMP("LRM",$J,GMTSJ,0),U,2)]"" D

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

 . . W "AFB Sme:",?12,$E($P(^TMP("LRM",$J,GMTSJ,0),U,2),1,20),!

 . . I $P(^TMP("LRM",$J,GMTSJ,0),U,3)]"" D

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

 . . . W ?12,$P(^TMP("LRM",$J,GMTSJ,0),U,3),!

 I $D(^TMP("LRM",$J,GMTSJ,"SMEAR")) D

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

 . W ?2,"Smear:"

 . S SMEAR=0

 . F  S SMEAR=$O(^TMP("LRM",$J,GMTSJ,"SMEAR",SMEAR)) Q:SMEAR'>0  W ?12,^(SMEAR),! I +$O(^TMP("LRM",$J,"SMEAR",SMEAR)) D CKP^GMTSUP Q:$D(GMTSQIT)

 Q

WRTNODE ; Writes current node of ^TMP("LRM",$J

 N GML,QTY

 I GMK=0 D CKP^GMTSUP Q:$D(GMTSQIT)  W ?1,"Report:",?12,$P(^TMP("LRM",$J,GMTSJ,GMK),U),! Q

 I GMTSJ="GRAM" D WRTGRM Q

 Q:GMK="SMEAR"

 I GMK="R" D REMARKS Q

 I GMTSJ'="CABXL" D  Q:$D(GMTSQIT)

 . D CKP^GMTSUP Q:$D(GMTSQIT)  W "Organsm:",?12,$P(^TMP("LRM",$J,GMTSJ,GMK),U),!

 . I $P(^TMP("LRM",$J,GMTSJ,GMK),U,2)]"" D CKP^GMTSUP Q:$D(GMTSQIT)  W ?4,"QTY:",?12,$P(^TMP("LRM",$J,GMTSJ,GMK),U,2),!

 I GMTSJ="CABXL" D

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

 . W:GMK=1 "Ser Abx:"

 . W ?12,$E($P(^TMP("LRM",$J,GMTSJ,GMK),U),1,18),?30,$$DRAW^GMTSLRM($P(^TMP("LRM",$J,GMTSJ,GMK),U,2)),?38,$P(^(GMK),U,3)," ug/ml",!

 I GMTSJ="BACT",$D(^TMP("LRM",$J,GMTSJ,GMK,"SUSC")) D ANTIBX Q

 I GMTSJ="PARA",$D(^TMP("LRM",$J,GMTSJ,GMK))=11 D

 . S GML=""

 . F  S GML=$O(^TMP("LRM",$J,GMTSJ,GMK,GML)) Q:GML'>0  D  Q:$D(GMTSQIT)

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

 . . W ?12,$P(^TMP("LRM",$J,GMTSJ,GMK,GML),U)

 . . S QTY=$P(^TMP("LRM",$J,GMTSJ,GMK,GML),U,2)

 . . I $L(QTY)>46 S QTY=$$WRAP^GMTSORC(QTY,46)

 . . W ?35,$P(QTY,"|"),!

 . . I $L($P(QTY,"|",2)) D CKP^GMTSUP Q:$D(GMTSQIT)  W ?35,$P(QTY,"|",2),!

 Q

REMARKS ; Write remarks

 N NUM,FIRST

 S NUM="",FIRST=1

 F  S NUM=$O(^TMP("LRM",$J,GMTSJ,GMK,NUM)) Q:+NUM'>0  D  Q:$D(GMTSQIT)

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

 . W:$X>0 !

 . I FIRST W "Remarks:" S FIRST=0

 . W ?12,^TMP("LRM",$J,GMTSJ,GMK,NUM),!

 Q

WRTGRM ; Writes Gram Stain Results

 D CKP^GMTSUP Q:$D(GMTSQIT)  W:$X>0 ! W:GMK=1 ?3,"Gram:" W ?12,$E(^TMP("LRM",$J,GMTSJ,GMK),1,69),!

 Q

ANTIBX ; Writes Antibiotic susceptability data

 N GML,GMCNT,ANAM,ANLEN,ANEXT,GMSUB

 S GMABX=1

 F GMSUB="S","I","R","O" D  Q:$D(GMTSQIT)

 . Q:+$D(^TMP("LRM",$J,GMTSJ,GMK,"SUSC",GMSUB))'>0

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

 . W:GMSUB="S" "Susc to:    "

 . W:GMSUB="I" "Interme:    "

 . W:GMSUB="R" "Resista:    "

 . W:GMSUB="O" "  Other:    "

 . S ANLEN=10,GML=""

 . F  S GML=$O(^TMP("LRM",$J,GMTSJ,GMK,"SUSC",GMSUB,GML)) Q:GML=""  S ANAM=$P($P(^(GML),U),";",2)_$S(GMSUB="O":"("_$P(^(GML),U,2)_"/"_$P(^(GML),U,3)_")",1:""),ANEXT=$O(^(GML)) D  Q:$D(GMTSQIT)

 . . I $L(ANAM)+ANLEN>79 D CKP^GMTSUP Q:$D(GMTSQIT)  W:'GMTSNPG ! W ?12 S ANLEN=10

 . . W ANAM,$S(ANEXT]"":", ",1:"") S ANLEN=ANLEN+$L(ANAM)+2

 . W !

 Q

WRTTEST ; Writes Lab Test for Accession

 N GML,GMCNT,TNAM,TLEN,TNEXT

 Q:'$D(^TMP("LRM",$J,GMTSJ,"TEST"))

 D CKP^GMTSUP Q:$D(GMTSQIT)  W "Test(s):    "

 S TLEN=10,GML=""

 F  S GML=$O(^TMP("LRM",$J,GMTSJ,"TEST",GML)) Q:GML=""  S TNAM=$P($G(^(GML)),U),TNEXT=$O(^(GML)) D  Q:$D(GMTSQIT)

 . I $L(TNAM)+TLEN>79 D CKP^GMTSUP Q:$D(GMTSQIT)  W:'GMTSNPG ! W ?12 S TLEN=10

 . W TNAM,$S(TNEXT]"":", ",1:"") S TLEN=TLEN+$L(TNAM)+2

 W !

 Q

GMTSLRMB  ; SLC/JER,KER - Microbiology Component Dvr ; 09/21/2001

 +1       ;;2.7;Health Summary;**25,28,47**;Oct 20, 1995

 +2       ;

 +3       ; External References

 +4       ;    DBIA   525  ^LR( all fields

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

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

 +7       ;                       

MAIN      ; Microbioloby Brief

 +1        NEW IX0,IX,LRDFN,MAX,D1,D2,D3

 +2        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)

 +4        SET IX=GMTS1

           FOR IX0=1:1:MAX

               SET IX=$ORDER(^LR(LRDFN,"MI",IX))

               IF +IX'>0!(IX>GMTS2)

                   QUIT 

               DO CKP^GMTSUP

               IF $DATA(GMTSQIT)

                   QUIT 

               Begin DoDot:1

 +5                DO ^GMTSLRME

                   IF $DATA(^TMP("LRM",$JOB))

                       Begin DoDot:2

 +6                        IF IX0>1

                               DO CKP^GMTSUP

                           IF $DATA(GMTSQIT)

                               QUIT 

                           IF IX0>1&'GMTSNPG

                               WRITE !

                           DO INTRP

                       End DoDot:2

 +7                KILL ^TMP("LRM",$JOB)

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +8        QUIT 

INTRP     ; Interprets ^TMP("LRM",$J

 +1        NEW GMTSJ,GMK,GMW,SMEAR,GMABX

 +2        SET (GMTSJ,GMK)=""

 +3        FOR 

               SET GMTSJ=$ORDER(^TMP("LRM",$JOB,GMTSJ))

               IF GMTSJ=""!$DATA(GMTSQIT)

                   QUIT 

               DO RDNODE

 +4        QUIT 

RDNODE    ; Reads current node of ^TMP("LRM",$J

 +1        IF GMTSJ="BSTER"

               QUIT 

 +2        IF GMTSJ=0

               Begin DoDot:1

 +3                DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

                   WRITE $PIECE($PIECE(^TMP("LRM",$JOB,GMTSJ),U)," "),?12,$PIECE(^TMP("LRM",$JOB,GMTSJ),U,3),!

 +4                DO WRTTEST

               End DoDot:1

               QUIT 

 +5        SET GMK=""

 +6        FOR 

               SET GMK=$ORDER(^TMP("LRM",$JOB,GMTSJ,GMK))

               IF GMK=""!$DATA(GMTSQIT)

                   QUIT 

               DO WRTNODE

 +7        IF GMTSJ="TB"

               Begin DoDot:1

 +8                IF $PIECE(^TMP("LRM",$JOB,GMTSJ,0),U,2)]""

                       Begin DoDot:2

 +9                        DO CKP^GMTSUP

                           IF $DATA(GMTSQIT)

                               QUIT 

 +10                       WRITE "AFB Sme:",?12,$EXTRACT($PIECE(^TMP("LRM",$JOB,GMTSJ,0),U,2),1,20),!

 +11                       IF $PIECE(^TMP("LRM",$JOB,GMTSJ,0),U,3)]""

                               Begin DoDot:3

 +12                               DO CKP^GMTSUP

                                   IF $DATA(GMTSQIT)

                                       QUIT 

 +13                               WRITE ?12,$PIECE(^TMP("LRM",$JOB,GMTSJ,0),U,3),!

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +14       IF $DATA(^TMP("LRM",$JOB,GMTSJ,"SMEAR"))

               Begin DoDot:1

 +15               DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

 +16               WRITE ?2,"Smear:"

 +17               SET SMEAR=0

 +18               FOR 

                       SET SMEAR=$ORDER(^TMP("LRM",$JOB,GMTSJ,"SMEAR",SMEAR))

                       IF SMEAR'>0

                           QUIT 

                       WRITE ?12,^(SMEAR),!

                       IF +$ORDER(^TMP("LRM",$JOB,"SMEAR",SMEAR))

                           DO CKP^GMTSUP

                           IF $DATA(GMTSQIT)

                               QUIT 

               End DoDot:1

 +19       QUIT 

WRTNODE   ; Writes current node of ^TMP("LRM",$J

 +1        NEW GML,QTY

 +2        IF GMK=0

               DO CKP^GMTSUP

               IF $DATA(GMTSQIT)

                   QUIT 

               WRITE ?1,"Report:",?12,$PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U),!

               QUIT 

 +3        IF GMTSJ="GRAM"

               DO WRTGRM

               QUIT 

 +4        IF GMK="SMEAR"

               QUIT 

 +5        IF GMK="R"

               DO REMARKS

               QUIT 

 +6        IF GMTSJ'="CABXL"

               Begin DoDot:1

 +7                DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

                   WRITE "Organsm:",?12,$PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U),!

 +8                IF $PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U,2)]""

                       DO CKP^GMTSUP

                       IF $DATA(GMTSQIT)

                           QUIT 

                       WRITE ?4,"QTY:",?12,$PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U,2),!

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +9        IF GMTSJ="CABXL"

               Begin DoDot:1

 +10               DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

 +11               IF GMK=1

                       WRITE "Ser Abx:"

 +12               WRITE ?12,$EXTRACT($PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U),1,18),?30,$$DRAW^GMTSLRM($PIECE(^TMP("LRM",$JOB,GMTSJ,GMK),U,2)),?38,$PIECE(^(GMK),U,3)," ug/ml",!

               End DoDot:1

 +13       IF GMTSJ="BACT"

               IF $DATA(^TMP("LRM",$JOB,GMTSJ,GMK,"SUSC"))

                   DO ANTIBX

                   QUIT 

 +14       IF GMTSJ="PARA"

               IF $DATA(^TMP("LRM",$JOB,GMTSJ,GMK))=11

                   Begin DoDot:1

 +15                   SET GML=""

 +16                   FOR 

                           SET GML=$ORDER(^TMP("LRM",$JOB,GMTSJ,GMK,GML))

                           IF GML'>0

                               QUIT 

                           Begin DoDot:2

 +17                           DO CKP^GMTSUP

                               IF $DATA(GMTSQIT)

                                   QUIT 

 +18                           WRITE ?12,$PIECE(^TMP("LRM",$JOB,GMTSJ,GMK,GML),U)

 +19                           SET QTY=$PIECE(^TMP("LRM",$JOB,GMTSJ,GMK,GML),U,2)

 +20                           IF $LENGTH(QTY)>46

                                   SET QTY=$$WRAP^GMTSORC(QTY,46)

 +21                           WRITE ?35,$PIECE(QTY,"|"),!

 +22                           IF $LENGTH($PIECE(QTY,"|",2))

                                   DO CKP^GMTSUP

                                   IF $DATA(GMTSQIT)

                                       QUIT 

                                   WRITE ?35,$PIECE(QTY,"|",2),!

                           End DoDot:2

                           IF $DATA(GMTSQIT)

                               QUIT 

                   End DoDot:1

 +23       QUIT 

REMARKS   ; Write remarks

 +1        NEW NUM,FIRST

 +2        SET NUM=""

           SET FIRST=1

 +3        FOR 

               SET NUM=$ORDER(^TMP("LRM",$JOB,GMTSJ,GMK,NUM))

               IF +NUM'>0

                   QUIT 

               Begin DoDot:1

 +4                DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

 +5                IF $X>0

                       WRITE !

 +6                IF FIRST

                       WRITE "Remarks:"

                       SET FIRST=0

 +7                WRITE ?12,^TMP("LRM",$JOB,GMTSJ,GMK,NUM),!

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +8        QUIT 

WRTGRM    ; Writes Gram Stain Results

 +1        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           IF $X>0

               WRITE !

           IF GMK=1

               WRITE ?3,"Gram:"

           WRITE ?12,$EXTRACT(^TMP("LRM",$JOB,GMTSJ,GMK),1,69),!

 +2        QUIT 

ANTIBX    ; Writes Antibiotic susceptability data

 +1        NEW GML,GMCNT,ANAM,ANLEN,ANEXT,GMSUB

 +2        SET GMABX=1

 +3        FOR GMSUB="S","I","R","O"

               Begin DoDot:1

 +4                IF +$DATA(^TMP("LRM",$JOB,GMTSJ,GMK,"SUSC",GMSUB))'>0

                       QUIT 

 +5                DO CKP^GMTSUP

                   IF $DATA(GMTSQIT)

                       QUIT 

 +6                IF GMSUB="S"

                       WRITE "Susc to:    "

 +7                IF GMSUB="I"

                       WRITE "Interme:    "

 +8                IF GMSUB="R"

                       WRITE "Resista:    "

 +9                IF GMSUB="O"

                       WRITE "  Other:    "

 +10               SET ANLEN=10

                   SET GML=""

 +11               FOR 

                       SET GML=$ORDER(^TMP("LRM",$JOB,GMTSJ,GMK,"SUSC",GMSUB,GML))

                       IF GML=""

                           QUIT 

                       SET ANAM=$PIECE($PIECE(^(GML),U),";",2)_$SELECT(GMSUB="O":"("_$PIECE(^(GML),U,2)_"/"_$PIECE(^(GML),U,3)_")",1:"")

                       SET ANEXT=$ORDER(^(GML))

                       Begin DoDot:2

 +12                       IF $LENGTH(ANAM)+ANLEN>79

                               DO CKP^GMTSUP

                               IF $DATA(GMTSQIT)

                                   QUIT 

                               IF 'GMTSNPG

                                   WRITE !

                               WRITE ?12

                               SET ANLEN=10

 +13                       WRITE ANAM,$SELECT(ANEXT]"":", ",1:"")

                           SET ANLEN=ANLEN+$LENGTH(ANAM)+2

                       End DoDot:2

                       IF $DATA(GMTSQIT)

                           QUIT 

 +14               WRITE !

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +15       QUIT 

WRTTEST   ; Writes Lab Test for Accession

 +1        NEW GML,GMCNT,TNAM,TLEN,TNEXT

 +2        IF '$DATA(^TMP("LRM",$JOB,GMTSJ,"TEST"))

               QUIT 

 +3        DO CKP^GMTSUP

           IF $DATA(GMTSQIT)

               QUIT 

           WRITE "Test(s):    "

 +4        SET TLEN=10

           SET GML=""

 +5        FOR 

               SET GML=$ORDER(^TMP("LRM",$JOB,GMTSJ,"TEST",GML))

               IF GML=""

                   QUIT 

               SET TNAM=$PIECE($GET(^(GML)),U)

               SET TNEXT=$ORDER(^(GML))

               Begin DoDot:1

 +6                IF $LENGTH(TNAM)+TLEN>79

                       DO CKP^GMTSUP

                       IF $DATA(GMTSQIT)

                           QUIT 

                       IF 'GMTSNPG

                           WRITE !

                       WRITE ?12

                       SET TLEN=10

 +7                WRITE TNAM,$SELECT(TNEXT]"":", ",1:"")

                   SET TLEN=TLEN+$LENGTH(TNAM)+2

               End DoDot:1

               IF $DATA(GMTSQIT)

                   QUIT 

 +8        WRITE !

 +9        QUIT