BGP8PC62 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
;
MMR(P) ;
NEW A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
S TCVX=$O(^ATXAX("B","BGP IPC MMR CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP IPC MMR CPT CODES",0))
S A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.Q:'$D(^ATXAX(TCVX,21,"B",I))
.S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
.I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D>A730
.S BGPIMMS(D)=Y
.Q
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 1 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 MMR"
;now get cpts
S G="",X=0
F S X=$O(^AUPNVCPT("AC",P,X)) Q:X="" D
.Q:'$D(^AUPNVCPT(X,0))
.S Y=$P(^AUPNVCPT(X,0),U)
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
.S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D>A730
.S BGPIMMS(D)=""
;get tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
.S V=$P(^AUPNVTC(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D>A730
.S BGPIMMS(D)=""
;
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 3 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>0 Q 1_U_"1 MMR"
;NOW CHECK FOR CONTRAINDICATION
;IMM PKG ANAPHYLACTIS
S BGPZ=0
F S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"") D
.S X=$$ANNECONT(P,BGPZ,A730)
I X]"" Q 1_U_"MMR CONTRA ANAPHYLACTIC/NEOMYCIN"
S X=$$ANSNMMR(P,A730) I X Q 1_U_"MMR CONTRA ANAPHYLACTIC REACTION"
S X=$$DIS^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA DIS IMMUNE SYS"
S X=$$HIV^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA HIV"
S X=$$MNLHT^BGP8PC65(P,A730) I X Q 1_U_"MMR CONTRA NEOPLASM"
S X=$$EVIDMMR(P,A730) I X Q 1_U_"EVIDENCE OF M/M/R"
Q ""
ANSNMMR(P,EDATE) ;
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D,I
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=292927007 S I=1 Q
.Q
I I Q I
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I S=292927007 S I=1
.Q:'I
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G) D
..S Y=9999999-D
..Q:Y>EDATE
..S G=1
I G Q G
;REFUSAL FILE
S I="" F S I=$O(^AUPNPREF("AA",P,9002318.4,I)) Q:I=""!(G) D
.I I'=292927007 Q ;IF IT'S SNOMED, MUST BE THAT ONE
.S ID=0 F S ID=$O(^AUPNPREF("AA",P,9002318.4,I,ID)) Q:ID=""!(G) D
..S D=9999999-ID
..Q:D>EDATE
..S G=1
Q G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contra Anaphylaxis"
.I $P(^BICONT(R,0),U,1)="Neomycin Allergy" S G=D_U_"Contra: Neomycin Allergy"
.I $P(^BICONT(R,0),U,1)="Immune Deficiency" S G=D_U_"Contra: Immune Deficiency"
Q G
EVIDMMR(P,EDATE) ;
;is there measles evidence
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D,E,R,L,J,ME,MU,RU
S (ME,MU,RU)=""
I $$PLTAXND^BGP8DU(P,"BGP IPC MEASLES DXS",EDATE,0) S ME=1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MEASLES EVID",EDATE,0) S ME=1
I $$LASTDX^BGP8UTL1(P,"BGP IPC MEASLES DXS",$$DOB^AUPNPAT(P),EDATE) S ME=1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T="PXRM BGP IPC MEASLES EVID"
S G=""
S S=0 F S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(ME) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(ME) D
..S Y=9999999-D
..Q:Y>EDATE
..S ME=1
I ME G MU
;lab tests?
MLT ;
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(ME) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(ME) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(ME) D
...Q:'$D(^AUPNVLAB(X,0))
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINCME(J)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S R=+R
...I R'<1.10 S ME=1
...Q
I 'ME Q "" ;since no measles and have to have all 3 might as well quit now
MU ;is there evidence of mumps?
I $$PLTAXND^BGP8DU(P,"BGP IPC MUMPS DXS",EDATE,0) S MU=1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MUMPS EVID",EDATE,0) S MU=1
I $$LASTDX^BGP8UTL1(P,"BGP IPC MUMPS DXS",$$DOB^AUPNPAT(P),EDATE) S MU=1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T="PXRM BGP IPC MUMPS EVID"
S G=""
S S=0 F S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(MU) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(MU) D
..S Y=9999999-D
..Q:Y>EDATE
..S MU=1
I MU G RU
;lab tests?
MULT ;
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(MU) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(MU) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(MU) D
...Q:'$D(^AUPNVLAB(X,0))
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINCMU(J)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S R=+R
...I R'<1.10 S MU=1
...Q
I 'MU Q "" ;since no MUMPS and have to have all 3 might as well quit now
RU ;
;is there evidence of RUBELLA?
I $$PLTAXND^BGP8DU(P,"BGP IPC RUBELLA DXS",EDATE,0) S RU=1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC RUBELLA EVID",EDATE,0) S RU=1
I $$LASTDX^BGP8UTL1(P,"BGP IPC RUBELLA DXS",$$DOB^AUPNPAT(P),EDATE) S RU=1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T="PXRM BGP IPC RUBELLA EVID"
S G=""
S S=0 F S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(MU) D
.Q:'$D(^AUPNVPOV("ASNC",P,S))
.S D=0 F S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(MU) D
..S Y=9999999-D
..Q:Y>EDATE
..S RU=1
I RU Q 1
;lab tests?
RULT ;
S E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(RU) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(RU) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(RU) D
...Q:'$D(^AUPNVLAB(X,0))
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINCRU(J)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S R=+R
...I R'<1.10 S RU=1
...Q
I 'RU Q "" ;since no RUBELLA and have to have all 3 might as well quit now
Q 1
LOINCME(A) ;is this a measles loinc code
NEW %
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I %="21500-4" Q 1
I %="21501-2" Q 1
I %="22501-1" Q 1
I %="22502-9" Q 1
Q ""
LOINCMU(A) ;is this a MUMPS loinc code
NEW %
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I %="21401-5" Q 1
I %="22416-2" Q 1
I %="22417-0" Q 1
I %="6477-4" Q 1
Q ""
LOINCRU(A) ;is this a RUBELLA loinc code
NEW %
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I %="41763-4" Q 1
I %="46110-3" Q 1
Q ""
BGP8PC62 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
+2 ;
MMR(P) ;
+1 NEW A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
+2 SET TCVX=$ORDER(^ATXAX("B","BGP IPC MMR CVX CODES",0))
+3 SET TCPT=$ORDER(^ATXAX("B","BGP IPC MMR CPT CODES",0))
+4 SET A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+7 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+8 ;happens too
IF 'Y
QUIT
+9 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+10 IF '$DATA(^ATXAX(TCVX,21,"B",I))
QUIT
+11 SET D=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U,1),".")
+12 IF D=""
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+13 IF D>A730
QUIT
+14 SET BGPIMMS(D)=Y
+15 QUIT
End DoDot:1
+16 ;go through and set into array if 1 days apart
+17 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+18 IF C=1
SET Y=X
QUIT
+19 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+20 SET Y=X
End DoDot:1
+21 ;see if there are 1 of them, if there are quit
+22 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+23 IF BGPIMMS>0
QUIT 1_U_"1 MMR"
+24 ;now get cpts
+25 SET G=""
SET X=0
+26 FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X=""
QUIT
Begin DoDot:1
+27 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+28 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+29 IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+30 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
IF 'V
QUIT
+31 SET D=$$VD^APCLV(V)
+32 IF D>A730
QUIT
+33 SET BGPIMMS(D)=""
End DoDot:1
+34 ;get tran codes
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+36 IF '$DATA(^AUPNVTC(X,0))
QUIT
+37 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
+38 IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+39 SET V=$PIECE(^AUPNVTC(X,0),U,3)
IF 'V
QUIT
+40 SET D=$$VD^APCLV(V)
+41 IF D>A730
QUIT
+42 SET BGPIMMS(D)=""
End DoDot:1
+43 ;
+44 ;go through and set into array if 1 days apart
+45 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+46 IF C=1
SET Y=X
QUIT
+47 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+48 SET Y=X
End DoDot:1
+49 ;see if there are 3 of them, if there are quit
+50 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+51 IF BGPIMMS>0
QUIT 1_U_"1 MMR"
+52 ;NOW CHECK FOR CONTRAINDICATION
+53 ;IMM PKG ANAPHYLACTIS
+54 SET BGPZ=0
+55 FOR
SET BGPZ=$ORDER(^ATXAX(TCVX,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
Begin DoDot:1
+56 SET X=$$ANNECONT(P,BGPZ,A730)
End DoDot:1
+57 IF X]""
QUIT 1_U_"MMR CONTRA ANAPHYLACTIC/NEOMYCIN"
+58 SET X=$$ANSNMMR(P,A730)
IF X
QUIT 1_U_"MMR CONTRA ANAPHYLACTIC REACTION"
+59 SET X=$$DIS^BGP8PC65(P,A730)
IF X
QUIT 1_U_"MMR CONTRA DIS IMMUNE SYS"
+60 SET X=$$HIV^BGP8PC65(P,A730)
IF X
QUIT 1_U_"MMR CONTRA HIV"
+61 SET X=$$MNLHT^BGP8PC65(P,A730)
IF X
QUIT 1_U_"MMR CONTRA NEOPLASM"
+62 SET X=$$EVIDMMR(P,A730)
IF X
QUIT 1_U_"EVIDENCE OF M/M/R"
+63 QUIT ""
ANSNMMR(P,EDATE) ;
+1 ;V POV OR PROBLEM LIST
+2 NEW X,Y,Z,G,T,S,D,I
+3 SET (X,Y,I)=0
+4 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNPROB(X,0))
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+8 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+9 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+10 IF S=292927007
SET I=1
QUIT
+11 QUIT
End DoDot:1
+12 IF I
QUIT I
+13 ;NOW V POV SNOMED
+14 ;NOW SNOMED USING ASNC
+15 SET G=""
SET I=""
+16 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+17 SET I=0
+18 IF S=292927007
SET I=1
+19 IF 'I
QUIT
+20 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+21 SET Y=9999999-D
+22 IF Y>EDATE
QUIT
+23 SET G=1
End DoDot:2
End DoDot:1
+24 IF G
QUIT G
+25 ;REFUSAL FILE
+26 SET I=""
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9002318.4,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+27 ;IF IT'S SNOMED, MUST BE THAT ONE
IF I'=292927007
QUIT
+28 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,9002318.4,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+29 SET D=9999999-ID
+30 IF D>EDATE
QUIT
+31 SET G=1
End DoDot:2
End DoDot:1
+32 QUIT G
ANNECONT(P,C,ED) ;EP - ANALPHYLAXIS/NEOMYCIN CONTRAINDICATION
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra Anaphylaxis"
+11 IF $PIECE(^BICONT(R,0),U,1)="Neomycin Allergy"
SET G=D_U_"Contra: Neomycin Allergy"
+12 IF $PIECE(^BICONT(R,0),U,1)="Immune Deficiency"
SET G=D_U_"Contra: Immune Deficiency"
End DoDot:1
+13 QUIT G
EVIDMMR(P,EDATE) ;
+1 ;is there measles evidence
+2 ;V POV OR PROBLEM LIST
+3 NEW X,Y,Z,G,T,S,D,E,R,L,J,ME,MU,RU
+4 SET (ME,MU,RU)=""
+5 IF $$PLTAXND^BGP8DU(P,"BGP IPC MEASLES DXS",EDATE,0)
SET ME=1
+6 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MEASLES EVID",EDATE,0)
SET ME=1
+7 IF $$LASTDX^BGP8UTL1(P,"BGP IPC MEASLES DXS",$$DOB^AUPNPAT(P),EDATE)
SET ME=1
+8 ;NOW V POV SNOMED
+9 ;NOW SNOMED USING ASNC
+10 SET T="PXRM BGP IPC MEASLES EVID"
+11 SET G=""
+12 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(ME)
QUIT
Begin DoDot:1
+13 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+14 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(ME)
QUIT
Begin DoDot:2
+15 SET Y=9999999-D
+16 IF Y>EDATE
QUIT
+17 SET ME=1
End DoDot:2
End DoDot:1
+18 IF ME
GOTO MU
+19 ;lab tests?
MLT ;
+1 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(ME)
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(ME)
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(ME)
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+6 IF '$$LOINCME(J)
QUIT
+7 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+8 SET R=+R
+9 IF R'<1.10
SET ME=1
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;since no measles and have to have all 3 might as well quit now
IF 'ME
QUIT ""
MU ;is there evidence of mumps?
+1 IF $$PLTAXND^BGP8DU(P,"BGP IPC MUMPS DXS",EDATE,0)
SET MU=1
+2 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC MUMPS EVID",EDATE,0)
SET MU=1
+3 IF $$LASTDX^BGP8UTL1(P,"BGP IPC MUMPS DXS",$$DOB^AUPNPAT(P),EDATE)
SET MU=1
+4 ;NOW V POV SNOMED
+5 ;NOW SNOMED USING ASNC
+6 SET T="PXRM BGP IPC MUMPS EVID"
+7 SET G=""
+8 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(MU)
QUIT
Begin DoDot:1
+9 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+10 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(MU)
QUIT
Begin DoDot:2
+11 SET Y=9999999-D
+12 IF Y>EDATE
QUIT
+13 SET MU=1
End DoDot:2
End DoDot:1
+14 IF MU
GOTO RU
+15 ;lab tests?
MULT ;
+1 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(MU)
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(MU)
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(MU)
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+6 IF '$$LOINCMU(J)
QUIT
+7 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+8 SET R=+R
+9 IF R'<1.10
SET MU=1
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;since no MUMPS and have to have all 3 might as well quit now
IF 'MU
QUIT ""
RU ;
+1 ;is there evidence of RUBELLA?
+2 IF $$PLTAXND^BGP8DU(P,"BGP IPC RUBELLA DXS",EDATE,0)
SET RU=1
+3 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC RUBELLA EVID",EDATE,0)
SET RU=1
+4 IF $$LASTDX^BGP8UTL1(P,"BGP IPC RUBELLA DXS",$$DOB^AUPNPAT(P),EDATE)
SET RU=1
+5 ;NOW V POV SNOMED
+6 ;NOW SNOMED USING ASNC
+7 SET T="PXRM BGP IPC RUBELLA EVID"
+8 SET G=""
+9 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(MU)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+11 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(MU)
QUIT
Begin DoDot:2
+12 SET Y=9999999-D
+13 IF Y>EDATE
QUIT
+14 SET RU=1
End DoDot:2
End DoDot:1
+15 IF RU
QUIT 1
+16 ;lab tests?
RULT ;
+1 SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(RU)
QUIT
Begin DoDot:1
+2 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(RU)
QUIT
Begin DoDot:2
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(RU)
QUIT
Begin DoDot:3
+4 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+5 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+6 IF '$$LOINCRU(J)
QUIT
+7 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+8 SET R=+R
+9 IF R'<1.10
SET RU=1
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;since no RUBELLA and have to have all 3 might as well quit now
IF 'RU
QUIT ""
+12 QUIT 1
LOINCME(A) ;is this a measles loinc code
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+3 IF %="21500-4"
QUIT 1
+4 IF %="21501-2"
QUIT 1
+5 IF %="22501-1"
QUIT 1
+6 IF %="22502-9"
QUIT 1
+7 QUIT ""
LOINCMU(A) ;is this a MUMPS loinc code
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+3 IF %="21401-5"
QUIT 1
+4 IF %="22416-2"
QUIT 1
+5 IF %="22417-0"
QUIT 1
+6 IF %="6477-4"
QUIT 1
+7 QUIT ""
LOINCRU(A) ;is this a RUBELLA loinc code
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+3 IF %="41763-4"
QUIT 1
+4 IF %="46110-3"
QUIT 1
+5 QUIT ""
