APCHS3E ; IHS/CMI/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
MIC ; ******************** MIC DATA * 9000010.09 *******
I '$D(^AUPNVMIC("AE",APCHSPAT)) G MICX
W !?3,"See the Lab Package for More Complete Microbiology Information than ",!,"contained below."
X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
X:'APCHSNPG APCHSBRK
; <SETUP>
K ^TMP($J,"APCHSMICP"),^TMP($J,"APCHMICA")
; <PROCESS>
D LBLD,LPRT
; <CLEANUP>
MICX K X,Y,C,D,T,O,P,A,N
K APCHSIVD,APCHSLT,APCHSIEN,APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL
K ^TMP($J,"APCHSMICP"),^TMP($J,"APCHMICA")
Q
; <BUILD>
LBLD ;
S APCHSIVD="" F S APCHSIVD=$O(^AUPNVMIC("AE",APCHSPAT,APCHSIVD)) Q:'APCHSIVD!(APCHSIVD>APCHSDLM) D LDATE
Q
LDATE S APCHSLT="" F S APCHSLT=$O(^AUPNVMIC("AE",APCHSPAT,APCHSIVD,APCHSLT)) Q:APCHSLT'=+APCHSLT D
.S APCHSIEN=0 F S APCHSIEN=$O(^AUPNVMIC("AE",APCHSPAT,APCHSIVD,APCHSLT,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN D LSET
Q
LSET ;
S N=$G(^AUPNVMIC(APCHSIEN,0))
S D=$P($P($G(^AUPNVMIC(APCHSIEN,12)),U),".") I D]"" S D=9999999-D
S P=$P($G(^AUPNVMIC(APCHSIEN,12)),U,8)
S O=$P(N,U,4),A=$P(N,U,5),C=$P(N,U,6),T=$P(N,U,1)
S:O="" O=0 S:A="" A=0 S:C="" C=0
Q:T=""
I P="" S ^TMP($J,"APCHSMICP",$S(D]"":D,1:APCHSIVD),C,T,APCHSIEN)=""
S ^TMP($J,"APCHMICA",C,T,O,A,APCHSIEN)=""
Q
; <PRINT>
LPRT ;
Q:'$D(^TMP($J,"APCHSMICP"))
W ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
S APCHSIVD="" F S APCHSIVD=$O(^TMP($J,"APCHSMICP",APCHSIVD)) Q:APCHSIVD'=+APCHSIVD!($D(APCHSQIT)) D
.S APCHSACC="" F S APCHSACC=$O(^TMP($J,"APCHSMICP",APCHSIVD,APCHSACC)) Q:APCHSACC=""!($D(APCHSQIT)) D
..S APCHS01=0 F S APCHS01=$O(^TMP($J,"APCHSMICP",APCHSIVD,APCHSACC,APCHS01)) Q:APCHS01'=+APCHS01!($D(APCHSQIT)) D
...S APCHSIEN=0 F S APCHSIEN=$O(^TMP($J,"APCHSMICP",APCHSIVD,APCHSACC,APCHS01,APCHSIEN)) Q:APCHSIEN'=+APCHSIEN!($D(APCHSQIT)) D LPRT2
...Q
..Q
.Q
Q
LPRT2 ;
;print all from this acc,.01
S APCHSORG="" F S APCHSORG=$O(^TMP($J,"APCHMICA",APCHSACC,APCHS01,APCHSORG)) Q:APCHSORG=""!($D(APCHSQIT)) D
.S APCHSANT="" F S APCHSANT=$O(^TMP($J,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT)) Q:APCHSANT=""!($D(APCHSQIT)) D
..S APCHSVL=0 F S APCHSVL=$O(^TMP($J,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL)) Q:APCHSVL'=+APCHSVL!($D(APCHSQIT)) D LPRT3
Q
LPRT3 ;write out line
S APCHSN=^AUPNVMIC(APCHSVL,0)
X APCHSCKP Q:$D(APCHSQIT) I APCHSNPG W ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
;write name
K ^TMP($J,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL)
;I APCHSANT=0,APCHSORG'=0 W !?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.04)," ",$$ORGR(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! Q
I APCHSANT=0,APCHSORG'=0 W !?2,$$VAL^XBDIQ1(9000010.25,APCHSVL,.04)," ",?34,$$ORGR(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,! Q
;I APCHSANT>0 W ?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.05),?34,$P(APCHSN,U,7) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! Q
I APCHSANT>0 W ?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.05),?34,$P(APCHSN,U,7) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,! Q
;W:'APCHSNPG ! W $P(^LAB(60,$P(APCHSN,U),0),U) S Y=(9999999-APCHSIVD) X APCHSCVD W ?58,Y,?47,$P(APCHSN,U,7) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! D
W:'APCHSNPG ! W $P(^LAB(60,$P(APCHSN,U),0),U) S Y=(9999999-APCHSIVD) X APCHSCVD D
.W:$P(^LAB(60,$P(APCHSN,U),0),U)["GRAM " ?34,$$GSR(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL)
.W ?58,Y S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,! D
..W ?2,"Site/Specimen: ",$$SITE(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL),!?2,"Collection Sample: ",$$COL(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL),!
Q
SITE(P,A,D,V) ;return site/specimen
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(D)="" Q ""
I $G(V)="" Q ""
I $P($G(^AUPNVMIC(V,11)),U,3)]"" Q $$VAL^XBDIQ1(9000010.25,V,1103)
NEW APCHLRDF,APCHIVD,X
S APCHLRDF=$P($G(^DPT(P,"LR")),U)
I APCHLRDF="" Q ""
S APCHIVD=9999999-D
I '$D(^LR(APCHLRDF,"MI",APCHIVD,0)) Q ""
I $P(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A Q ""
S X=$P(^LR(APCHLRDF,"MI",APCHIVD,0),U,5)
I 'X Q ""
I '$D(^LAB(61,X,0)) Q ""
Q $P(^LAB(61,X,0),U)
;
COL(P,A,D,V) ;
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(D)="" Q ""
I $G(V)="" Q ""
I $P($G(^AUPNVMIC(V,0)),U,8)]"" Q $$VAL^XBDIQ1(9000010.25,V,.08)
NEW APCHLRDF,APCHIVD,X
S APCHLRDF=$P($G(^DPT(P,"LR")),U)
I APCHLRDF="" Q ""
S APCHIVD=9999999-D
I '$D(^LR(APCHLRDF,"MI",APCHIVD,0)) Q ""
I $P(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A Q ""
S X=$P(^LR(APCHLRDF,"MI",APCHIVD,0),U,11)
I 'X Q ""
I '$D(^LAB(62,X,0)) Q ""
Q $P(^LAB(62,X,0),U)
;
GSR(P,A,D,V) ;
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(D)="" Q ""
I $G(V)="" Q ""
NEW APCHLRDF,APCHIVD,X,R
S R=$$VAL^XBDIQ1(9000010.25,V,.07)
S APCHLRDF=$P($G(^DPT(P,"LR")),U)
I APCHLRDF="" Q ""
S APCHIVD=9999999-D
I '$D(^LR(APCHLRDF,"MI",APCHIVD,0)) Q ""
I $P(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A Q ""
S X=$G(^LR(APCHLRDF,"MI",APCHIVD,2,1,0))
I X="" Q ""
;
Q X
ORGR(P,A,D,V) ;
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(D)="" Q ""
I $G(V)="" Q ""
NEW APCHLRDF,APCHIVD,X,R
S R=$$VAL^XBDIQ1(9000010.25,V,.07)
S APCHLRDF=$P($G(^DPT(P,"LR")),U)
I APCHLRDF="" Q ""
S APCHIVD=9999999-D
I '$D(^LR(APCHLRDF,"MI",APCHIVD,0)) Q ""
I $P(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A Q ""
S X=$P($G(^LR(APCHLRDF,"MI",APCHIVD,3,1,0)),U,2)
I X="" Q ""
;
Q X
APCHS3E ; IHS/CMI/LAB - PART 3 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
MIC ; ******************** MIC DATA * 9000010.09 *******
+1 IF '$DATA(^AUPNVMIC("AE",APCHSPAT))
GOTO MICX
+2 WRITE !?3,"See the Lab Package for More Complete Microbiology Information than ",!,"contained below."
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
+4 IF 'APCHSNPG
XECUTE APCHSBRK
+5 ; <SETUP>
+6 KILL ^TMP($JOB,"APCHSMICP"),^TMP($JOB,"APCHMICA")
+7 ; <PROCESS>
+8 DO LBLD
DO LPRT
+9 ; <CLEANUP>
MICX KILL X,Y,C,D,T,O,P,A,N
+1 KILL APCHSIVD,APCHSLT,APCHSIEN,APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL
+2 KILL ^TMP($JOB,"APCHSMICP"),^TMP($JOB,"APCHMICA")
+3 QUIT
+4 ; <BUILD>
LBLD ;
+1 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(^AUPNVMIC("AE",APCHSPAT,APCHSIVD))
IF 'APCHSIVD!(APCHSIVD>APCHSDLM)
QUIT
DO LDATE
+2 QUIT
LDATE SET APCHSLT=""
FOR
SET APCHSLT=$ORDER(^AUPNVMIC("AE",APCHSPAT,APCHSIVD,APCHSLT))
IF APCHSLT'=+APCHSLT
QUIT
Begin DoDot:1
+1 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^AUPNVMIC("AE",APCHSPAT,APCHSIVD,APCHSLT,APCHSIEN))
IF APCHSIEN'=+APCHSIEN
QUIT
DO LSET
End DoDot:1
+2 QUIT
LSET ;
+1 SET N=$GET(^AUPNVMIC(APCHSIEN,0))
+2 SET D=$PIECE($PIECE($GET(^AUPNVMIC(APCHSIEN,12)),U),".")
IF D]""
SET D=9999999-D
+3 SET P=$PIECE($GET(^AUPNVMIC(APCHSIEN,12)),U,8)
+4 SET O=$PIECE(N,U,4)
SET A=$PIECE(N,U,5)
SET C=$PIECE(N,U,6)
SET T=$PIECE(N,U,1)
+5 IF O=""
SET O=0
IF A=""
SET A=0
IF C=""
SET C=0
+6 IF T=""
QUIT
+7 IF P=""
SET ^TMP($JOB,"APCHSMICP",$SELECT(D]"":D,1:APCHSIVD),C,T,APCHSIEN)=""
+8 SET ^TMP($JOB,"APCHMICA",C,T,O,A,APCHSIEN)=""
+9 QUIT
+10 ; <PRINT>
LPRT ;
+1 IF '$DATA(^TMP($JOB,"APCHSMICP"))
QUIT
+2 WRITE ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
+3 SET APCHSIVD=""
FOR
SET APCHSIVD=$ORDER(^TMP($JOB,"APCHSMICP",APCHSIVD))
IF APCHSIVD'=+APCHSIVD!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+4 SET APCHSACC=""
FOR
SET APCHSACC=$ORDER(^TMP($JOB,"APCHSMICP",APCHSIVD,APCHSACC))
IF APCHSACC=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+5 SET APCHS01=0
FOR
SET APCHS01=$ORDER(^TMP($JOB,"APCHSMICP",APCHSIVD,APCHSACC,APCHS01))
IF APCHS01'=+APCHS01!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+6 SET APCHSIEN=0
FOR
SET APCHSIEN=$ORDER(^TMP($JOB,"APCHSMICP",APCHSIVD,APCHSACC,APCHS01,APCHSIEN))
IF APCHSIEN'=+APCHSIEN!($DATA(APCHSQIT))
QUIT
DO LPRT2
+7 QUIT
End DoDot:3
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
LPRT2 ;
+1 ;print all from this acc,.01
+2 SET APCHSORG=""
FOR
SET APCHSORG=$ORDER(^TMP($JOB,"APCHMICA",APCHSACC,APCHS01,APCHSORG))
IF APCHSORG=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+3 SET APCHSANT=""
FOR
SET APCHSANT=$ORDER(^TMP($JOB,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT))
IF APCHSANT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+4 SET APCHSVL=0
FOR
SET APCHSVL=$ORDER(^TMP($JOB,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL))
IF APCHSVL'=+APCHSVL!($DATA(APCHSQIT))
QUIT
DO LPRT3
End DoDot:2
End DoDot:1
+5 QUIT
LPRT3 ;write out line
+1 SET APCHSN=^AUPNVMIC(APCHSVL,0)
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE ?34,"RESULT",?58,"COLL DATE",?68,"COMP DATE",!
+3 ;write name
+4 KILL ^TMP($JOB,"APCHMICA",APCHSACC,APCHS01,APCHSORG,APCHSANT,APCHSVL)
+5 ;I APCHSANT=0,APCHSORG'=0 W !?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.04)," ",$$ORGR(APCHSPAT,APCHSACC,$P($G(^AUPNVMIC(APCHSVL,12)),U),APCHSVL) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! Q
+6 IF APCHSANT=0
IF APCHSORG'=0
WRITE !?2,$$VAL^XBDIQ1(9000010.25,APCHSVL,.04)," ",?34,$$ORGR(APCHSPAT,APCHSACC,$PIECE($GET(^AUPNVMIC(APCHSVL,12)),U),APCHSVL)
SET Y=$PIECE(APCHSN,U,9)
XECUTE APCHSCVD
WRITE ?68,Y,!
QUIT
+7 ;I APCHSANT>0 W ?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.05),?34,$P(APCHSN,U,7) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! Q
+8 IF APCHSANT>0
WRITE ?3,$$VAL^XBDIQ1(9000010.25,APCHSVL,.05),?34,$PIECE(APCHSN,U,7)
SET Y=$PIECE(APCHSN,U,9)
XECUTE APCHSCVD
WRITE ?68,Y,!
QUIT
+9 ;W:'APCHSNPG ! W $P(^LAB(60,$P(APCHSN,U),0),U) S Y=(9999999-APCHSIVD) X APCHSCVD W ?58,Y,?47,$P(APCHSN,U,7) S Y=$P(APCHSN,U,9) X APCHSCVD W ?68,Y,?79,$E($P($G(^AUPNVMIC(APCHSVL,11)),U,9)),! D
+10 IF 'APCHSNPG
WRITE !
WRITE $PIECE(^LAB(60,$PIECE(APCHSN,U),0),U)
SET Y=(9999999-APCHSIVD)
XECUTE APCHSCVD
Begin DoDot:1
+11 IF $PIECE(^LAB(60,$PIECE(APCHSN,U),0),U)["GRAM "
WRITE ?34,$$GSR(APCHSPAT,APCHSACC,$PIECE($GET(^AUPNVMIC(APCHSVL,12)),U),APCHSVL)
+12 WRITE ?58,Y
SET Y=$PIECE(APCHSN,U,9)
XECUTE APCHSCVD
WRITE ?68,Y,!
Begin DoDot:2
+13 WRITE ?2,"Site/Specimen: ",$$SITE(APCHSPAT,APCHSACC,$PIECE($GET(^AUPNVMIC(APCHSVL,12)),U),APCHSVL),!?2,"Collection Sample: ",$$COL(APCHSPAT,APCHSACC,$PIECE($GET(^AUPNVMIC(APCHSVL,12)),U),APCHSVL),!
End DoDot:2
End DoDot:1
+14 QUIT
SITE(P,A,D,V) ;return site/specimen
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(D)=""
QUIT ""
+4 IF $GET(V)=""
QUIT ""
+5 IF $PIECE($GET(^AUPNVMIC(V,11)),U,3)]""
QUIT $$VAL^XBDIQ1(9000010.25,V,1103)
+6 NEW APCHLRDF,APCHIVD,X
+7 SET APCHLRDF=$PIECE($GET(^DPT(P,"LR")),U)
+8 IF APCHLRDF=""
QUIT ""
+9 SET APCHIVD=9999999-D
+10 IF '$DATA(^LR(APCHLRDF,"MI",APCHIVD,0))
QUIT ""
+11 IF $PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A
QUIT ""
+12 SET X=$PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,5)
+13 IF 'X
QUIT ""
+14 IF '$DATA(^LAB(61,X,0))
QUIT ""
+15 QUIT $PIECE(^LAB(61,X,0),U)
+16 ;
COL(P,A,D,V) ;
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(D)=""
QUIT ""
+4 IF $GET(V)=""
QUIT ""
+5 IF $PIECE($GET(^AUPNVMIC(V,0)),U,8)]""
QUIT $$VAL^XBDIQ1(9000010.25,V,.08)
+6 NEW APCHLRDF,APCHIVD,X
+7 SET APCHLRDF=$PIECE($GET(^DPT(P,"LR")),U)
+8 IF APCHLRDF=""
QUIT ""
+9 SET APCHIVD=9999999-D
+10 IF '$DATA(^LR(APCHLRDF,"MI",APCHIVD,0))
QUIT ""
+11 IF $PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A
QUIT ""
+12 SET X=$PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,11)
+13 IF 'X
QUIT ""
+14 IF '$DATA(^LAB(62,X,0))
QUIT ""
+15 QUIT $PIECE(^LAB(62,X,0),U)
+16 ;
GSR(P,A,D,V) ;
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(D)=""
QUIT ""
+4 IF $GET(V)=""
QUIT ""
+5 NEW APCHLRDF,APCHIVD,X,R
+6 SET R=$$VAL^XBDIQ1(9000010.25,V,.07)
+7 SET APCHLRDF=$PIECE($GET(^DPT(P,"LR")),U)
+8 IF APCHLRDF=""
QUIT ""
+9 SET APCHIVD=9999999-D
+10 IF '$DATA(^LR(APCHLRDF,"MI",APCHIVD,0))
QUIT ""
+11 IF $PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A
QUIT ""
+12 SET X=$GET(^LR(APCHLRDF,"MI",APCHIVD,2,1,0))
+13 IF X=""
QUIT ""
+14 ;
+15 QUIT X
ORGR(P,A,D,V) ;
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(D)=""
QUIT ""
+4 IF $GET(V)=""
QUIT ""
+5 NEW APCHLRDF,APCHIVD,X,R
+6 SET R=$$VAL^XBDIQ1(9000010.25,V,.07)
+7 SET APCHLRDF=$PIECE($GET(^DPT(P,"LR")),U)
+8 IF APCHLRDF=""
QUIT ""
+9 SET APCHIVD=9999999-D
+10 IF '$DATA(^LR(APCHLRDF,"MI",APCHIVD,0))
QUIT ""
+11 IF $PIECE(^LR(APCHLRDF,"MI",APCHIVD,0),U,6)'=A
QUIT ""
+12 SET X=$PIECE($GET(^LR(APCHLRDF,"MI",APCHIVD,3,1,0)),U,2)
+13 IF X=""
QUIT ""
+14 ;
+15 QUIT X
