BDMD418 ; IHS/CMI/LAB - 2012 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2007 code set versioning in WT
;
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BDMARRY,H,E,D,W
S E=$O(^AUTTMSR("B","HT",0))
S H=""
S D=0 F S D=$O(^AUPNVMSR("AA",P,E,D)) Q:D'=+D!(H]"") D
.S W=0 F S W=$O(^AUPNVMSR("AA",P,E,D,W)) Q:W'=+W!(H]"") D
..Q:'$D(^AUPNVMSR(W,0))
..Q:$P($G(^AUPNVMSR(W,2)),U,1) ;entered in error
..S H=$P(^AUPNVMSR(W,0),U,4)
..S BDMARRAY(1)=$$VD^APCLV($P(^AUPNVMSR(W,0),U,3))
I H="" Q H
I H["?" Q ""
S H=$J(H,5,2)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
.S BDMVF=+$P(BDM(BDMN),U,4)
.Q:$P($G(^AUPNVMSR(BDMVF,2)),U,1) ;entered in error
.S BDMZ=$P(BDM(BDMN),U,5)
.I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q
. S BDMD=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BDMD,0),U)),U,2) D ;cmi/anch/maw 9/12/2007 csv
...I $E(ICD,1,3)="V22" Q
...I $E(ICD,1,3)="V23" Q
...I $E(ICD,1,3)="V27" Q
...I $E(ICD,1,3)="V28" Q
...I ICD>629.9999&(ICD<676.95) Q
...S BDMW=$P(BDM(BDMN),U,2)
..Q
Q BDMW
BMI(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,W,H,B,D,%DT,X
S %=""
D Q %
.S W=$$WT(P,BDATE,EDATE) Q:W="" S W=W+.5,W=$P(W,".")
.S HDATE=$P(^DPT(P,0),U,3)
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
.Q
Q
CREAT(P,BDATE,EDATE,F) ;EP
G CREAT^BDMD41C
CHOL(P,BDATE,EDATE,F) ;EP
G CHOL^BDMD41C
HDL(P,BDATE,EDATE,F) ;EP
G HDL^BDMD41C
LDL(P,BDATE,EDATE,F) ;EP
G LDL^BDMD41C
TRIG(P,BDATE,EDATE,F) ;EP
G TRIG^BDMD41C
URIN(P,BDATE,EDATE) ;EP
G URIN^BDMD41H
PROTEIN(P,BDATE,EDATE) ;EP
G PROTEIN^BDMD41C
MICRO(P,BDATE,EDATE) ;EP
G MICRO^BDMD41C
HGBA1C(P,BDATE,EDATE) ;EP
G HGBA1C^BDMD41D
SEMI(P,BDATE,EDATE) ;EP
G SEMI^BDMD41C
PPDS(P) ;
NEW BDMS,E,X
K BDMS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_" HF: "_$P(BDMS(1),U,3)
PPDSPL ;CHECK PL
N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
I 'T Q ""
N X,Y,I S (X,Y,I)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=X
I I Q 1_U_$$VAL^XBDIQ1(9000011,I,.03)_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
;check povs
K BDMS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS(1)) Q 1_U_$$FMTE^XLFDT($P(BDMS(1),U))_" POV: "_$P(BDMS(1),U,3)
Q ""
PPD(P,EDATE,F) ;EP
;f 1=tb test done
;f 2=tb result
S F=$G(F)
;RETURN 1^1 Skin Test||1 Positive
NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
S LD="",LR=""
S X=EDATE,%DT="P" D ^%DT S ED=Y
S G=$$PPDS(P) I G Q "1 TB Positive "_$P(G,U,2)_"||1 Positive TB "_$P(G,U,2) ;IF HAD HF or dx or pl of TB use it as positive
K BDM
;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
S X=$O(^AUTTSK("B","PPD",0))
S D=9999999-ED-1,C=0 F S D=$O(^AUPNVSK("AA",P,X,D)) Q:D="" D
.S G=0 F S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G D
..Q:'$D(^AUPNVSK(G,0))
..S C=C+1 S BDM(D,C)="ST"_U_G_U_$P(^AUPNVSK(G,0),U,5)_U_$S($P(^AUPNVSK(G,0),U,4)="D":"",$P(^AUPNVSK(G,0),U,4)="O":"",1:$P(^AUPNVSK(G,0),U,4))
;go through all ppds and find last reading or result
;S G="",D=0,X=0 F S D=$O(BDM(D)) Q:D'=+D!(G) S X=0 F S X=$O(BDM(D,X)) Q:X'=+X S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D
;S LD=R2
;I R]"",R>9 S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R]"",R<10 S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R1]"",R1="P" S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;I R1]"",R1="N" S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
;Now get last lab test, must have a result
S BDMC=0
S BDMLT=$O(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
S BDMOT=$O(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
S G="",E=9999999-ED S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...Q:$$UP^XLFSTR($P(^AUPNVLAB(X,0),U,4))["CANC"
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) D
....S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q:'BDMOT
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BDMD41C(J,BDMOT)
...S C=C+1,BDM(D,C)="LAB^"_X_U_$P(^AUPNVLAB(X,0),U,4),G=1
...Q
;now get latest with a result and use it, if none with a result take latest one
;if none, quit on value
S (D,C)=0,G=""
F S D=$O(BDM(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BDM(D,C)) Q:C'=+C!(G]"") D
..I $P(BDM(D,C),U,3)]""!($P(BDM(D,C),U,4)]"") S G=BDM(D,C)
I F="I" Q $S($P(G,U,1)="LAB":$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3)),1:$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3)))
I G]"" S C="" D Q C ;C=1 skin test||result value
.S C=$S($P(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
.;GET RESULT VALUE
.I $P(G,U,1)="LAB" S R=$P(G,U,3) D Q
..I $E($$UP^XLFSTR(R))="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..I $E($$UP^XLFSTR(R))="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVLAB($P(G,U,2),0),U,3),"S")_" lab result: "_R Q
..S C=C_"||4 Unknown" Q
.I $P(G,U,1)="ST" D Q
..S R=$P(G,U,3),R1=$P(G,U,4)
..I R]"",R>9 S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R]"",R<10 S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="P" S C=C_"||1 Positive "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
..I R1]"",R1="N" S C=C_"||2 Negative "_$$VD^APCLV($P(^AUPNVSK($P(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1 Q
;now check refusal for PPD or lab test
S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 S X=$$REFUSAL^BDMD417(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) I X S G=X
I G Q "3 Refused "_$P(G,U,3)_" "_$P(G,U,4)_" "_$P(G,U,5)_"||3 Refused"
;now check lab test refusal - lori
Q "4 Unknown||"
;
LASTNP(P,EDATE) ;EP - last negative ppd
I $E($P($$PPD(P,EDATE),"||",2))'="2" Q ""
Q $$PPD(P,EDATE,"I")
;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
G FGLUCOSE^BDMD41D
G75(P,BDATE,EDATE,F) ;EP
G G75^BDMD41D
;
STV(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
I X="" Q X ;no value in X so don't bother
I X="?" Q ""
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1".",X'?1"+",X'?1"-",X'?1">",X'?1"<" S X=$$STRIP^XLFSTR(X,A) S B=B-1
I X="" Q ""
I $G(D),X["." S X=$J(X,T,D)
S X=$$STRIP^XLFSTR(X," ")
Q $E(X,1,T)
ASPIRIN ;EP
NEW X,BDM,E,A,N,G,T,T1,O,B,%
S (A,B,G,N)=""
S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S A=1
K BDM S X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S N=1
I A!(N) Q "1 Aspirin/Antiplatelet Rx"
;CHECK NON-VA MEDS for drug or orderable item that is not-discontinued
S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
S X=0,%="" F S X=$O(^PS(55,P,"NVA",X)) Q:X'=+X!(%]"") D
.I $P($G(^PS(55,P,"NVA",X,999999911)),U,1),$D(^AUPNVMED($P(^PS(55,P,"NVA",X,999999911),U,1),0)) Q ;got this with V MED
.S L=$P($P($G(^PS(55,P,"NVA",X,0)),U,10),".")
.Q:$P(^PS(55,P,"NVA",X,0),U,6)=1 ;discontinued
.I $P(^PS(55,P,"NVA",X,0),U,7)]"",$P(^PS(55,P,"NVA",X,0),U,7)<EDATE Q ;discontinued date
.Q:$P(^PS(55,P,"NVA",X,0),U,9)>EDATE ;
.S D=$P(^PS(55,P,"NVA",X,0),U,2)
.I D S G=0 D
..I $D(^ATXAX(T,21,"B",D)) S G=1
..I $D(^ATXAX(T1,21,"B",D)) S G=1
.I D,G S %="1 Yes - NVA MED - "_$P(^PSDRUG(D,0),U,1) Q
.S O=$P(^PS(55,P,"NVA",X,0),U,1)
.Q:O=""
.S O=$P($G(^PS(50.7,O,0)),U,1)
.Q:O=""
.I $E(O,1,7)="ASPIRIN",$E(O,8)'="/" S %="1 Yes - NVA MED - "_O Q
I %]"" Q %
;refusal oR NMI
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T G ANTI
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "3 Refused"
I G Q "2 None - Not Medically Indicated"
ANTI ;
NEW T S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
I 'T G AR
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "3 Refused or adverse reaction"
AR ;NOW CHECK FOR ADVERSE REACTION/ALLERGY
S X=EDATE,%DT="P" D ^%DT S E=Y
D ASAALLEG(P,E,.BDMSAAL) ;return text of aspirin allergy if found
I $D(BDMSAAL(1)) Q "3 Refused or adverse reaction "_BDMSAAL(1)_" (Allergy Tracking)"
Q "2 None"
;
;
;;
ASAALLEG(P,BDMD,BDMY) ;does patient have an aspirin allergy
;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
NEW ED,BD,BDMG,BDMC,X,Y,Z,N
;BDMD is discharge date
S BDMC=0 K BDMY
;S ED=$$FMADD^XLFDT(BDMD,-365)
ASAPOV ;
K BDMG S Y="BDMG(",X=P_"^ALL DX [BDM ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BDMG(X)) Q:X'=+X S Y=+$P(BDMG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV: "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_"] "_N
.;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 orig line
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 csv
.Q
K BDMG S Y="BDMG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BDMG(X)) Q:X'=+X S Y=+$P(BDMG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV: "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_"] "_N
.Q
;now check problem list for these codes
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.;S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BDMD ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="PROBLEM LIST: "_$$FMTE^XLFDT($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
;now check allergy tracking
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>BDMD ;entered after AUDIT date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ASPIRIN" S BDMC=BDMC+1,BDMY(BDMC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N Q
.S C=$O(^PS(50.605,"B","CN103",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL100",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL110",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL117",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.Q
Q
BDMD418 ; IHS/CMI/LAB - 2012 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning in WT
+4 ;
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BDMARRY,H,E,D,W
+3 SET E=$ORDER(^AUTTMSR("B","HT",0))
+4 SET H=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",P,E,D))
IF D'=+D!(H]"")
QUIT
Begin DoDot:1
+6 SET W=0
FOR
SET W=$ORDER(^AUPNVMSR("AA",P,E,D,W))
IF W'=+W!(H]"")
QUIT
Begin DoDot:2
+7 IF '$DATA(^AUPNVMSR(W,0))
QUIT
+8 ;entered in error
IF $PIECE($GET(^AUPNVMSR(W,2)),U,1)
QUIT
+9 SET H=$PIECE(^AUPNVMSR(W,0),U,4)
+10 SET BDMARRAY(1)=$$VD^APCLV($PIECE(^AUPNVMSR(W,0),U,3))
End DoDot:2
End DoDot:1
+11 IF H=""
QUIT H
+12 IF H["?"
QUIT ""
+13 SET H=$JUSTIFY(H,5,2)
+14 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD,BDMVF
+3 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+4 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+5 SET BDMVF=+$PIECE(BDM(BDMN),U,4)
+6 ;entered in error
IF $PIECE($GET(^AUPNVMSR(BDMVF,2)),U,1)
QUIT
+7 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+8 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)
QUIT
+9 SET BDMD=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(BDMW]"")
QUIT
Begin DoDot:2
+10 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BDMD,0),U)),U,2)
Begin DoDot:3
+11 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+13 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+14 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+15 IF ICD>629.9999&(ICD<676.95)
QUIT
+16 SET BDMW=$PIECE(BDM(BDMN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BDMW
BMI(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,W,H,B,D,%DT,X
+3 SET %=""
+4 Begin DoDot:1
+5 SET W=$$WT(P,BDATE,EDATE)
IF W=""
QUIT
SET W=W+.5
SET W=$PIECE(W,".")
+6 SET HDATE=$PIECE(^DPT(P,0),U,3)
+7 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+8 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+9 QUIT
End DoDot:1
QUIT %
+10 QUIT
CREAT(P,BDATE,EDATE,F) ;EP
+1 GOTO CREAT^BDMD41C
CHOL(P,BDATE,EDATE,F) ;EP
+1 GOTO CHOL^BDMD41C
HDL(P,BDATE,EDATE,F) ;EP
+1 GOTO HDL^BDMD41C
LDL(P,BDATE,EDATE,F) ;EP
+1 GOTO LDL^BDMD41C
TRIG(P,BDATE,EDATE,F) ;EP
+1 GOTO TRIG^BDMD41C
URIN(P,BDATE,EDATE) ;EP
+1 GOTO URIN^BDMD41H
PROTEIN(P,BDATE,EDATE) ;EP
+1 GOTO PROTEIN^BDMD41C
MICRO(P,BDATE,EDATE) ;EP
+1 GOTO MICRO^BDMD41C
HGBA1C(P,BDATE,EDATE) ;EP
+1 GOTO HGBA1C^BDMD41D
SEMI(P,BDATE,EDATE) ;EP
+1 GOTO SEMI^BDMD41C
PPDS(P) ;
+1 NEW BDMS,E,X
+2 KILL BDMS
+3 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDMS(")
+4 IF $DATA(BDMS)
QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_" HF: "_$PIECE(BDMS(1),U,3)
PPDSPL ;CHECK PL
+1 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
+2 IF 'T
QUIT ""
+3 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXCHK(Y,T,9)
SET I=X
+4 IF I
QUIT 1_U_$$VAL^XBDIQ1(9000011,I,.03)_" Problem List: "_$$VAL^XBDIQ1(9000011,I,.01)
+5 ;check povs
+6 KILL BDMS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"BDMS(")
+7 IF $DATA(BDMS(1))
QUIT 1_U_$$FMTE^XLFDT($PIECE(BDMS(1),U))_" POV: "_$PIECE(BDMS(1),U,3)
+8 QUIT ""
PPD(P,EDATE,F) ;EP
+1 ;f 1=tb test done
+2 ;f 2=tb result
+3 SET F=$GET(F)
+4 ;RETURN 1^1 Skin Test||1 Positive
+5 NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED,LD,LR
+6 SET LD=""
SET LR=""
+7 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+8 ;IF HAD HF or dx or pl of TB use it as positive
SET G=$$PPDS(P)
IF G
QUIT "1 TB Positive "_$PIECE(G,U,2)_"||1 Positive TB "_$PIECE(G,U,2)
+9 KILL BDM
+10 ;get, in reverse order all skin tests and lab tests for TB testing (BDM(inverse date,#)=ST or LAB^ien^result^reading
+11 SET X=$ORDER(^AUTTSK("B","PPD",0))
+12 SET D=9999999-ED-1
SET C=0
FOR
SET D=$ORDER(^AUPNVSK("AA",P,X,D))
IF D=""
QUIT
Begin DoDot:1
+13 SET G=0
FOR
SET G=$ORDER(^AUPNVSK("AA",P,X,D,G))
IF G'=+G
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSK(G,0))
QUIT
+15 SET C=C+1
SET BDM(D,C)="ST"_U_G_U_$PIECE(^AUPNVSK(G,0),U,5)_U_$SELECT($PIECE(^AUPNVSK(G,0),U,4)="D":"",$PIECE(^AUPNVSK(G,0),U,4)="O":"",1:$PIECE(^AUPNVSK(G,0),U,4))
End DoDot:2
End DoDot:1
+16 ;go through all ppds and find last reading or result
+17 ;S G="",D=0,X=0 F S D=$O(BDM(D)) Q:D'=+D!(G) S X=0 F S X=$O(BDM(D,X)) Q:X'=+X S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D
+18 ;S LD=R2
+19 ;I R]"",R>9 S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+20 ;I R]"",R<10 S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+21 ;I R1]"",R1="P" S LR=1_U_1_U_"1 SKIN TEST"_U_"1 POSITIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+22 ;I R1]"",R1="N" S LR=1_U_2_U_"1 SKIN TEST"_U_"2 NEGATIVE "_$$FMTE^XLFDT(R2)_" Reading: "_R_" Result: "_R1
+23 ;Now get last lab test, must have a result
+24 SET BDMC=0
+25 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT TB LAB TESTS",0))
+26 SET BDMOT=$ORDER(^ATXAX("B","DM AUDIT TB TEST LOINC",0))
+27 SET G=""
SET E=9999999-ED
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+28 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+30 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+31 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+32 IF $$UP^XLFSTR($PIECE(^AUPNVLAB(X,0),U,4))["CANC"
QUIT
+33 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+34 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
End DoDot:4
+35 IF 'BDMOT
QUIT
+36 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+37 IF '$$LOINC^BDMD41C(J,BDMOT)
QUIT
+38 SET C=C+1
SET BDM(D,C)="LAB^"_X_U_$PIECE(^AUPNVLAB(X,0),U,4)
SET G=1
+39 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;now get latest with a result and use it, if none with a result take latest one
+41 ;if none, quit on value
+42 SET (D,C)=0
SET G=""
+43 FOR
SET D=$ORDER(BDM(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+44 SET C=0
FOR
SET C=$ORDER(BDM(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+45 IF $PIECE(BDM(D,C),U,3)]""!($PIECE(BDM(D,C),U,4)]"")
SET G=BDM(D,C)
End DoDot:2
End DoDot:1
+46 IF F="I"
QUIT $SELECT($PIECE(G,U,1)="LAB":$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3)),1:$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3)))
+47 ;C=1 skin test||result value
IF G]""
SET C=""
Begin DoDot:1
+48 SET C=$SELECT($PIECE(G,U,1)="ST":"1 Skin test (PPD)",1:"2 Blood Test (QFT-G, T SPOT-TB)")
+49 ;GET RESULT VALUE
+50 IF $PIECE(G,U,1)="LAB"
SET R=$PIECE(G,U,3)
Begin DoDot:2
+51 IF $EXTRACT($$UP^XLFSTR(R))="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+52 IF $EXTRACT($$UP^XLFSTR(R))="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVLAB($PIECE(G,U,2),0),U,3),"S")_" lab result: "_R
QUIT
+53 SET C=C_"||4 Unknown"
QUIT
End DoDot:2
QUIT
+54 IF $PIECE(G,U,1)="ST"
Begin DoDot:2
+55 SET R=$PIECE(G,U,3)
SET R1=$PIECE(G,U,4)
+56 IF R]""
IF R>9
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+57 IF R]""
IF R<10
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+58 IF R1]""
IF R1="P"
SET C=C_"||1 Positive "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
+59 IF R1]""
IF R1="N"
SET C=C_"||2 Negative "_$$VD^APCLV($PIECE(^AUPNVSK($PIECE(G,U,2),0),U,3),"S")_" Reading: "_R_" Result: "_R1
QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT C
+60 ;now check refusal for PPD or lab test
+61 SET X=EDATE
SET %DT="P"
DO ^%DT
SET BDATE=$$FMADD^XLFDT(Y,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET G=0
SET X=$$REFUSAL^BDMD417(P,9999999.28,$ORDER(^AUTTSK("B","PPD",0)),BDATE,EDATE)
IF X
SET G=X
+62 IF G
QUIT "3 Refused "_$PIECE(G,U,3)_" "_$PIECE(G,U,4)_" "_$PIECE(G,U,5)_"||3 Refused"
+63 ;now check lab test refusal - lori
+64 QUIT "4 Unknown||"
+65 ;
LASTNP(P,EDATE) ;EP - last negative ppd
+1 IF $EXTRACT($PIECE($$PPD(P,EDATE),"||",2))'="2"
QUIT ""
+2 QUIT $$PPD(P,EDATE,"I")
+3 ;
FGLUCOSE(P,BDATE,EDATE,F) ;EP
+1 GOTO FGLUCOSE^BDMD41D
G75(P,BDATE,EDATE,F) ;EP
+1 GOTO G75^BDMD41D
+2 ;
STV(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+6 IF X=""
QUIT ""
+7 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+8 SET X=$$STRIP^XLFSTR(X," ")
+9 QUIT $EXTRACT(X,1,T)
STE(X,T,D) ;EP - strip hgba1c before epi export
+1 ;no value in X so don't bother
IF X=""
QUIT X
+2 IF X="?"
QUIT ""
+3 NEW A,B,L
+4 SET L=$LENGTH(X)
+5 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
IF X'?1"+"
IF X'?1"-"
IF X'?1">"
IF X'?1"<"
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+6 IF X=""
QUIT ""
+7 IF $GET(D)
IF X["."
SET X=$JUSTIFY(X,T,D)
+8 SET X=$$STRIP^XLFSTR(X," ")
+9 QUIT $EXTRACT(X,1,T)
ASPIRIN ;EP
+1 NEW X,BDM,E,A,N,G,T,T1,O,B,%
+2 SET (A,B,G,N)=""
+3 SET X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+4 IF $DATA(BDM(1))
SET A=1
+5 KILL BDM
SET X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 IF $DATA(BDM(1))
SET N=1
+7 IF A!(N)
QUIT "1 Aspirin/Antiplatelet Rx"
+8 ;CHECK NON-VA MEDS for drug or orderable item that is not-discontinued
+9 SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+10 SET T1=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+11 SET X=0
SET %=""
FOR
SET X=$ORDER(^PS(55,P,"NVA",X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+12 ;got this with V MED
IF $PIECE($GET(^PS(55,P,"NVA",X,999999911)),U,1)
IF $DATA(^AUPNVMED($PIECE(^PS(55,P,"NVA",X,999999911),U,1),0))
QUIT
+13 SET L=$PIECE($PIECE($GET(^PS(55,P,"NVA",X,0)),U,10),".")
+14 ;discontinued
IF $PIECE(^PS(55,P,"NVA",X,0),U,6)=1
QUIT
+15 ;discontinued date
IF $PIECE(^PS(55,P,"NVA",X,0),U,7)]""
IF $PIECE(^PS(55,P,"NVA",X,0),U,7)<EDATE
QUIT
+16 ;
IF $PIECE(^PS(55,P,"NVA",X,0),U,9)>EDATE
QUIT
+17 SET D=$PIECE(^PS(55,P,"NVA",X,0),U,2)
+18 IF D
SET G=0
Begin DoDot:2
+19 IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+20 IF $DATA(^ATXAX(T1,21,"B",D))
SET G=1
End DoDot:2
+21 IF D
IF G
SET %="1 Yes - NVA MED - "_$PIECE(^PSDRUG(D,0),U,1)
QUIT
+22 SET O=$PIECE(^PS(55,P,"NVA",X,0),U,1)
+23 IF O=""
QUIT
+24 SET O=$PIECE($GET(^PS(50.7,O,0)),U,1)
+25 IF O=""
QUIT
+26 IF $EXTRACT(O,1,7)="ASPIRIN"
IF $EXTRACT(O,8)'="/"
SET %="1 Yes - NVA MED - "_O
QUIT
End DoDot:1
+27 IF %]""
QUIT %
+28 ;refusal oR NMI
+29 SET G=0
+30 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+31 IF 'T
GOTO ANTI
+32 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD417(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+33 IF G
IF $PIECE(G,U,2)'="N"
QUIT "3 Refused"
+34 IF G
QUIT "2 None - Not Medically Indicated"
ANTI ;
+1 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+2 IF 'T
GOTO AR
+3 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD417(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+4 IF G
QUIT "3 Refused or adverse reaction"
AR ;NOW CHECK FOR ADVERSE REACTION/ALLERGY
+1 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+2 ;return text of aspirin allergy if found
DO ASAALLEG(P,E,.BDMSAAL)
+3 IF $DATA(BDMSAAL(1))
QUIT "3 Refused or adverse reaction "_BDMSAAL(1)_" (Allergy Tracking)"
+4 QUIT "2 None"
+5 ;
+6 ;
+7 ;;
ASAALLEG(P,BDMD,BDMY) ;does patient have an aspirin allergy
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
+2 NEW ED,BD,BDMG,BDMC,X,Y,Z,N
+3 ;BDMD is discharge date
+4 SET BDMC=0
KILL BDMY
+5 ;S ED=$$FMADD^XLFDT(BDMD,-365)
ASAPOV ;
+1 KILL BDMG
SET Y="BDMG("
SET X=P_"^ALL DX [BDM ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV: "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_"] "_N
+5 ;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 orig line
+6 ;cmi/anch/maw 9/12/2007 csv
SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E935.3"
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_" + E935.3] "_N
+7 QUIT
End DoDot:1
+8 KILL BDMG
SET Y="BDMG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD)
SET E=$$START1^APCLDF(X,Y)
+9 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+10 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+11 IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV: "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_"] "_N
+12 QUIT
End DoDot:1
+13 ;now check problem list for these codes
+14 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+15 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+16 ;S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
+17 ;cmi/anch/maw 9/12/2007 csv
SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+18 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+19 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>BDMD
QUIT
+20 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="PROBLEM LIST: "_$$FMTE^XLFDT($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+21 QUIT
End DoDot:1
+22 ;now check allergy tracking
+23 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+24 ;entered after AUDIT date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BDMD
QUIT
+25 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+26 IF N["ASPIRIN"
SET BDMC=BDMC+1
SET BDMY(BDMC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($PIECE(^GMR(120.8,X,0),U,4))_" "_N
QUIT
+27 SET C=$ORDER(^PS(50.605,"B","CN103",0))
+28 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+29 SET C=$ORDER(^PS(50.605,"B","BL100",0))
+30 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+31 SET C=$ORDER(^PS(50.605,"B","BL110",0))
+32 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+33 SET C=$ORDER(^PS(50.605,"B","BL117",0))
+34 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+35 QUIT
End DoDot:1
+36 QUIT
