LRMIPSZ4 ;DALOI/RBN - MICRO PATIENT REPORT - AFB, FUNGUS ;Jul 15, 2021@13:13
;;5.2;LAB SERVICE;**350,547**;Sep 27, 1994;Build 10
;
;Reference to ^DD supported by ICR #999
;
Q
;
TB ;
; from LRMIPSZ1
; also called from RPT^LROR4
N B,LRBLDTMP,LRQUIT,LRTA,LRX
S (LRBLDTMP,LRQUIT)=0
I '$D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT)) D ;
. S LRBLDTMP=1
. M ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
. K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT,32)
;
I $P(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,11),U)="",'$G(LRLABKY) D S:'$D(LRWRDVEW) LRQUIT=1 S:LRSB'=11 LRQUIT=1
. Q:'$D(^XTMP("LRMICRO EDIT",LRDFN,LRIDT,11))
. ;LR*5.2*547: Display informational message if accession/test is currently being edited
. ; and results had previously been verified.
. N LR7SB S LR7SB=11
. D MES^LRMIPSZ2
;
I LRQUIT D Q
. I LRBLDTMP K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)
;
S LRX=^TMP("LRMI",$J,LRDFN,"MI",LRIDT,11)
S LRTUS=$P(LRX,U,2),DZ=$P(LRX,U,5),LRAFS=$P(LRX,U,3),LRAMT=$P(LRX,U,4),Y=$P(LRX,U)
D D^LRU
W:LRHC !
W !,"* MYCOBACTERIOLOGY ",$S(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")," REPORT => "_Y_" TECH CODE: "_DZ
S LRPRE=23
D PRE^LRMIPSU
;
S LRTA=""
I $O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,0)) S LRTA=0
D:LRAFS'=""!(LRTA=0) AFS
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,13)) D ;
. W:LRHC !
. W !,"Mycobacteriology Remark(s):"
. D NP Q:LRABORT
. S B=0
. F S B=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,13,B)) Q:B<1 W !,?3,^(B,0) D NP Q:LRABORT
;
I LRBLDTMP K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)
Q
;
;
AFS ; Acid Fast Stain results
;
N LRX,X
;
I LRAFS'="" D
. S LRX="Acid Fast Stain: "
. I LRAFS?1(1"DP",1"DN",1"CP",1"CN") D
. . S LRX=$S($E(LRAFS)="D":"Direct ",$E(LRAFS)="C":"Concentrate ",1:"")_LRX
. . S LRX=LRX_$S($E(LRAFS,2)="P":"Positive",$E(LRAFS,2)="N":"Negative",1:LRAFS)
. E D
. . S X=$$GET1^DIQ(63.05,LRIDT_","_LRDFN_",",24)
. . I X'="" S LRX=LRX_X Q
. . S LRX=LRX_LRAFS
. W:LRHC ! W !,LRX
. I LRAMT'="" W !,?3,"Quantity: ",LRAMT
;
K ^TMP("LR",$J,"T"),LRTSTS
;
I LRTA=0 D
. S LRTSTS=0
. F S LRTA=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA)) Q:LRTA<1 D
. . S (LRBUG(LRTA),LRTBC)=$P(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,0),U)
. . S LRQU=$P(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,0),U,2)
. . S LRTBC=$P(^LAB(61.2,LRTBC,0),U)
. . D LIST
;
Q
;
;
LIST ; List organisms
;
N B,LRTB,LRTBA,LRTBS,LRX
W:LRHC !
D NP Q:LRABORT
W !,"Mycobacterium: ",LRTBC
D NP Q:LRABORT
I LRQU'="" W !,?3,"Quantity: ",LRQU D NP Q:LRABORT
S:$D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,2)) LRTSTS=LRTSTS+1
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA)) D Q:LRABORT ;
. W !," Comment: "
. D NP Q:LRABORT
. S B=0
. F S B=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,1,B)) Q:B<1 W ?13,^(B,0),! D NP Q:LRABORT
;
;
SEN ; Display AFB sensitivities.
;
S LRTB=2
F S LRTB=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,LRTB)) Q:LRTB'["2."!(LRTB="") D ;
. S LRTBS=^TMP("LRMI",$J,LRDFN,"MI",LRIDT,12,LRTA,LRTB)
. I LRTBS="" Q
. S LRTBA=""
. I $D(^LAB(62.06,"AD1",LRTB)) D
. . S LRX=$O(^LAB(62.06,"AD1",LRTB,0)),LRX(0)=""
. . I LRX S LRX(0)=$G(^LAB(62.06,LRX,0))
. . S LRTBA=$P(LRX(0),"^")
. I LRTBA="" D
. . S LRTBA=$O(^DD(63.39,"GL",LRTB,1,0))
. . S LRTBA=$P(^DD(63.39,LRTBA,0),U)
. W !,?3,$$LJ^XLFSTR(LRTBA,30,"."),?34,LRTBS
Q
;
;
FUNG ;
; from LRMIPSZ1
; also called from RPT^LROR4
N LRBLDTMP,LRQUIT
S (LRBLDTMP,LRQUIT)=0
I '$D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT)) D ;
. S LRBLDTMP=1
. M ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
. K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT,32)
;
I $P(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,8),U)="",'$G(LRLABKY) D S:'$D(LRWRDVEW) LRQUIT=1 S:LRSB'=8 LRQUIT=1
. Q:'$D(^XTMP("LRMICRO EDIT",LRDFN,LRIDT,8))
. ;LR*5.2*547: Display informational message if accession/test is currently being edited
. ; and results had previously been verified.
. N LR7SB S LR7SB=8
. D MES^LRMIPSZ2
;
I LRQUIT D Q
. I LRBLDTMP K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)
;
S LRTUS=$P(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,8),U,2)
S DZ=$P(^(8),U,3),Y=$P(^(8),U)
D D^LRU
W:LRHC !
D NP Q:LRABORT
W !,"* MYCOLOGY ",$S(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")," REPORT => ",Y," TECH CODE: ",DZ
D NP Q:LRABORT
S LRPRE=22 D PRE^LRMIPSU
D QA
;
I LRBLDTMP K ^TMP("LRMI",$J,LRDFN,"MI",LRIDT)
Q
;
;
QA ;
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,15)) D ;
. W:LRHC !
. D NP Q:LRABORT
. W !,"MYCOLOGY SMEAR/PREP:"
. S LRMYC=0
. F S LRMYC=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,15,LRMYC)) Q:LRMYC<1 W !?5,^(LRMYC,0) D NP Q:LRABORT
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,9)) D ;
. W:LRHC !
. D NP Q:LRABORT
. W !,"Fungus/Yeast: "
. D NP Q:LRABORT
. D SHOW
;
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,10)) D ;
. W:LRHC !
. D NP Q:LRABORT
. W !,"Mycology Remark(s):"
. D NP Q:LRABORT
. S LRMYC=0
. F S LRMYC=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,10,LRMYC)) Q:LRMYC<1 W !,?3,^(LRMYC,0) D NP Q:LRABORT
;
Q
;
;
SHOW ;
;
S LRTA=0
F S LRTA=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,9,LRTA)) Q:LRTA?.N2A.E!(LRTA<1) D
. S LRTA=+LRTA
. S (LRBUG(LRTA),LRTBC)=$P(^(LRTA,0),U)
. S LRQU=$P(^(0),U,2)
. S LRTBC=$P(^LAB(61.2,LRTBC,0),U)
. D LIST1
;
Q
;
;
LIST1 ;
;
N B
W !,LRTBC
D NP Q:LRABORT
I LRQU'="" W !,?3,"Quantity: ",LRQU
D NP Q:LRABORT
I $D(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,9,LRTA,1,0)) D ;
. W !,?3,"Comment:"
. S B=0
. F S B=+$O(^TMP("LRMI",$J,LRDFN,"MI",LRIDT,9,LRTA,1,B)) Q:B<1 W ?13,^(B,0),! D NP Q:LRABORT
Q
;
;
NP ;
; Convenience method
D NP^LRMIPSZ1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIPSZ4 5701 printed Sep 23, 2025@19:52:55 Page 2
LRMIPSZ4 ;DALOI/RBN - MICRO PATIENT REPORT - AFB, FUNGUS ;Jul 15, 2021@13:13
+1 ;;5.2;LAB SERVICE;**350,547**;Sep 27, 1994;Build 10
+2 ;
+3 ;Reference to ^DD supported by ICR #999
+4 ;
+5 QUIT
+6 ;
TB ;
+1 ; from LRMIPSZ1
+2 ; also called from RPT^LROR4
+3 NEW B,LRBLDTMP,LRQUIT,LRTA,LRX
+4 SET (LRBLDTMP,LRQUIT)=0
+5 ;
IF '$DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT))
Begin DoDot:1
+6 SET LRBLDTMP=1
+7 MERGE ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
+8 KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,32)
End DoDot:1
+9 ;
+10 IF $PIECE(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,11),U)=""
IF '$GET(LRLABKY)
Begin DoDot:1
+11 if '$DATA(^XTMP("LRMICRO EDIT",LRDFN,LRIDT,11))
QUIT
+12 ;LR*5.2*547: Display informational message if accession/test is currently being edited
+13 ; and results had previously been verified.
+14 NEW LR7SB
SET LR7SB=11
+15 DO MES^LRMIPSZ2
End DoDot:1
if '$DATA(LRWRDVEW)
SET LRQUIT=1
if LRSB'=11
SET LRQUIT=1
+16 ;
+17 IF LRQUIT
Begin DoDot:1
+18 IF LRBLDTMP
KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)
End DoDot:1
QUIT
+19 ;
+20 SET LRX=^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,11)
+21 SET LRTUS=$PIECE(LRX,U,2)
SET DZ=$PIECE(LRX,U,5)
SET LRAFS=$PIECE(LRX,U,3)
SET LRAMT=$PIECE(LRX,U,4)
SET Y=$PIECE(LRX,U)
+22 DO D^LRU
+23 if LRHC
WRITE !
+24 WRITE !,"* MYCOBACTERIOLOGY ",$SELECT(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")," REPORT => "_Y_" TECH CODE: "_DZ
+25 SET LRPRE=23
+26 DO PRE^LRMIPSU
+27 ;
+28 SET LRTA=""
+29 IF $ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,0))
SET LRTA=0
+30 if LRAFS'=""!(LRTA=0)
DO AFS
+31 ;
+32 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,13))
Begin DoDot:1
+33 if LRHC
WRITE !
+34 WRITE !,"Mycobacteriology Remark(s):"
+35 DO NP
if LRABORT
QUIT
+36 SET B=0
+37 FOR
SET B=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,13,B))
if B<1
QUIT
WRITE !,?3,^(B,0)
DO NP
if LRABORT
QUIT
End DoDot:1
+38 ;
+39 IF LRBLDTMP
KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)
+40 QUIT
+41 ;
+42 ;
AFS ; Acid Fast Stain results
+1 ;
+2 NEW LRX,X
+3 ;
+4 IF LRAFS'=""
Begin DoDot:1
+5 SET LRX="Acid Fast Stain: "
+6 IF LRAFS?1(1"DP",1"DN",1"CP",1"CN")
Begin DoDot:2
+7 SET LRX=$SELECT($EXTRACT(LRAFS)="D":"Direct ",$EXTRACT(LRAFS)="C":"Concentrate ",1:"")_LRX
+8 SET LRX=LRX_$SELECT($EXTRACT(LRAFS,2)="P":"Positive",$EXTRACT(LRAFS,2)="N":"Negative",1:LRAFS)
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 SET X=$$GET1^DIQ(63.05,LRIDT_","_LRDFN_",",24)
+11 IF X'=""
SET LRX=LRX_X
QUIT
+12 SET LRX=LRX_LRAFS
End DoDot:2
+13 if LRHC
WRITE !
WRITE !,LRX
+14 IF LRAMT'=""
WRITE !,?3,"Quantity: ",LRAMT
End DoDot:1
+15 ;
+16 KILL ^TMP("LR",$JOB,"T"),LRTSTS
+17 ;
+18 IF LRTA=0
Begin DoDot:1
+19 SET LRTSTS=0
+20 FOR
SET LRTA=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA))
if LRTA<1
QUIT
Begin DoDot:2
+21 SET (LRBUG(LRTA),LRTBC)=$PIECE(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,0),U)
+22 SET LRQU=$PIECE(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,0),U,2)
+23 SET LRTBC=$PIECE(^LAB(61.2,LRTBC,0),U)
+24 DO LIST
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
+28 ;
LIST ; List organisms
+1 ;
+2 NEW B,LRTB,LRTBA,LRTBS,LRX
+3 if LRHC
WRITE !
+4 DO NP
if LRABORT
QUIT
+5 WRITE !,"Mycobacterium: ",LRTBC
+6 DO NP
if LRABORT
QUIT
+7 IF LRQU'=""
WRITE !,?3,"Quantity: ",LRQU
DO NP
if LRABORT
QUIT
+8 if $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,2))
SET LRTSTS=LRTSTS+1
+9 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA))
Begin DoDot:1
+10 WRITE !," Comment: "
+11 DO NP
if LRABORT
QUIT
+12 SET B=0
+13 FOR
SET B=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,1,B))
if B<1
QUIT
WRITE ?13,^(B,0),!
DO NP
if LRABORT
QUIT
End DoDot:1
if LRABORT
QUIT
+14 ;
+15 ;
SEN ; Display AFB sensitivities.
+1 ;
+2 SET LRTB=2
+3 ;
FOR
SET LRTB=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,LRTB))
if LRTB'["2."!(LRTB="")
QUIT
Begin DoDot:1
+4 SET LRTBS=^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,12,LRTA,LRTB)
+5 IF LRTBS=""
QUIT
+6 SET LRTBA=""
+7 IF $DATA(^LAB(62.06,"AD1",LRTB))
Begin DoDot:2
+8 SET LRX=$ORDER(^LAB(62.06,"AD1",LRTB,0))
SET LRX(0)=""
+9 IF LRX
SET LRX(0)=$GET(^LAB(62.06,LRX,0))
+10 SET LRTBA=$PIECE(LRX(0),"^")
End DoDot:2
+11 IF LRTBA=""
Begin DoDot:2
+12 SET LRTBA=$ORDER(^DD(63.39,"GL",LRTB,1,0))
+13 SET LRTBA=$PIECE(^DD(63.39,LRTBA,0),U)
End DoDot:2
+14 WRITE !,?3,$$LJ^XLFSTR(LRTBA,30,"."),?34,LRTBS
End DoDot:1
+15 QUIT
+16 ;
+17 ;
FUNG ;
+1 ; from LRMIPSZ1
+2 ; also called from RPT^LROR4
+3 NEW LRBLDTMP,LRQUIT
+4 SET (LRBLDTMP,LRQUIT)=0
+5 ;
IF '$DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT))
Begin DoDot:1
+6 SET LRBLDTMP=1
+7 MERGE ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)=^LR(LRDFN,"MI",LRIDT)
+8 KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,32)
End DoDot:1
+9 ;
+10 IF $PIECE(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,8),U)=""
IF '$GET(LRLABKY)
Begin DoDot:1
+11 if '$DATA(^XTMP("LRMICRO EDIT",LRDFN,LRIDT,8))
QUIT
+12 ;LR*5.2*547: Display informational message if accession/test is currently being edited
+13 ; and results had previously been verified.
+14 NEW LR7SB
SET LR7SB=8
+15 DO MES^LRMIPSZ2
End DoDot:1
if '$DATA(LRWRDVEW)
SET LRQUIT=1
if LRSB'=8
SET LRQUIT=1
+16 ;
+17 IF LRQUIT
Begin DoDot:1
+18 IF LRBLDTMP
KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)
End DoDot:1
QUIT
+19 ;
+20 SET LRTUS=$PIECE(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,8),U,2)
+21 SET DZ=$PIECE(^(8),U,3)
SET Y=$PIECE(^(8),U)
+22 DO D^LRU
+23 if LRHC
WRITE !
+24 DO NP
if LRABORT
QUIT
+25 WRITE !,"* MYCOLOGY ",$SELECT(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")," REPORT => ",Y," TECH CODE: ",DZ
+26 DO NP
if LRABORT
QUIT
+27 SET LRPRE=22
DO PRE^LRMIPSU
+28 DO QA
+29 ;
+30 IF LRBLDTMP
KILL ^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT)
+31 QUIT
+32 ;
+33 ;
QA ;
+1 ;
+2 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,15))
Begin DoDot:1
+3 if LRHC
WRITE !
+4 DO NP
if LRABORT
QUIT
+5 WRITE !,"MYCOLOGY SMEAR/PREP:"
+6 SET LRMYC=0
+7 FOR
SET LRMYC=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,15,LRMYC))
if LRMYC<1
QUIT
WRITE !?5,^(LRMYC,0)
DO NP
if LRABORT
QUIT
End DoDot:1
+8 ;
+9 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,9))
Begin DoDot:1
+10 if LRHC
WRITE !
+11 DO NP
if LRABORT
QUIT
+12 WRITE !,"Fungus/Yeast: "
+13 DO NP
if LRABORT
QUIT
+14 DO SHOW
End DoDot:1
+15 ;
+16 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,10))
Begin DoDot:1
+17 if LRHC
WRITE !
+18 DO NP
if LRABORT
QUIT
+19 WRITE !,"Mycology Remark(s):"
+20 DO NP
if LRABORT
QUIT
+21 SET LRMYC=0
+22 FOR
SET LRMYC=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,10,LRMYC))
if LRMYC<1
QUIT
WRITE !,?3,^(LRMYC,0)
DO NP
if LRABORT
QUIT
End DoDot:1
+23 ;
+24 QUIT
+25 ;
+26 ;
SHOW ;
+1 ;
+2 SET LRTA=0
+3 FOR
SET LRTA=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,9,LRTA))
if LRTA?.N2A.E!(LRTA<1)
QUIT
Begin DoDot:1
+4 SET LRTA=+LRTA
+5 SET (LRBUG(LRTA),LRTBC)=$PIECE(^(LRTA,0),U)
+6 SET LRQU=$PIECE(^(0),U,2)
+7 SET LRTBC=$PIECE(^LAB(61.2,LRTBC,0),U)
+8 DO LIST1
End DoDot:1
+9 ;
+10 QUIT
+11 ;
+12 ;
LIST1 ;
+1 ;
+2 NEW B
+3 WRITE !,LRTBC
+4 DO NP
if LRABORT
QUIT
+5 IF LRQU'=""
WRITE !,?3,"Quantity: ",LRQU
+6 DO NP
if LRABORT
QUIT
+7 ;
IF $DATA(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,9,LRTA,1,0))
Begin DoDot:1
+8 WRITE !,?3,"Comment:"
+9 SET B=0
+10 FOR
SET B=+$ORDER(^TMP("LRMI",$JOB,LRDFN,"MI",LRIDT,9,LRTA,1,B))
if B<1
QUIT
WRITE ?13,^(B,0),!
DO NP
if LRABORT
QUIT
End DoDot:1
+11 QUIT
+12 ;
+13 ;
NP ;
+1 ; Convenience method
+2 DO NP^LRMIPSZ1
+3 QUIT
