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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRMB 4423 printed Nov 22, 2024@17:07:57 Page 2
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
+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
