APCLD816 ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
;
TBCODE(P,EDATE,R) ;EP
NEW APCLJ,APCLI,X,APCLR
S APCLJ=""
;return computed TB Status Code
S X=$$TBTX^APCLD812(P)
I X]"",X["TX COMPLETE" Q 1
I X]"" Q 2
S APCLR=$$PPD^APCLD818(P,EDATE)
I APCLR["POS" D Q APCLJ
.I $$TBTX^APCLD812(P)["TX COMPLETE" S APCLJ=1 Q
.S APCLJ=2
.Q
I APCLR["NEG" S APCLJ=4 D Q APCLJ
.I $$DODX(P,R,"I")="" S APCLJ=6 Q
.S D=$$DODX(P,R,"I"),E=$$PPD^APCLD818(P,EDATE,"I") S APCLJ=$S(D>E:4,1:3)
.Q
I APCLR["Unknown" S APCLJ=5
I APCLR["Refus" S APCLJ=7
Q APCLJ
;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, placed on or after date of DM dx
4 ;;PPD -, placed before date of DM dx
5 ;;PPD Status unknown
6 ;;PPD -, date of DX or PPD date unknown
7 ;;PPD Refused
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/")+C
Q C\3
Q ""
DIAMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/",2)+C
Q C\3
PPDDATE(P,EDATE) ;EP
NEW X S X=$$LASTNP^APCLD818(P,EDATE)
Q X
LIPID(P,BDATE,EDATE) ;EP
NEW X,APCL,E,G,S,O
S (S,O,G)="",X=P_"^MEDS [DM AUDIT LIPID LOWERING DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S O=1
K APCL
S X=P_"^MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S S=1
I S,O Q "Both"
I S Q "Statin"
I O Q "Other"
;refusal
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
I 'T Q "None"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^APCLD817(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "Refused or Adverse Rxn"
NEW T S T=$O(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
I 'T G LIPIDA
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^APCLD817(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "Refused or Adverse Rxn"
LIPIDA ;
;check patient allergies file for any with va drug class CV350
S X=EDATE,%DT="P" D ^%DT S B=Y
S X=0,G="" 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),".")>B ;entered after discharge date
.S C=$O(^PS(50.605,"B","CV350",0))
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.;I N["ASPIRIN" S APCLC=APCLC+1,APCLY(APCLC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn"
.;S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.;I N["ASPIRIN" S APCLC=APCLC+1,APCLY(APCLC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N
I G]"" Q G
Q "None"
;
;
ACE(P,BDATE,EDATE) ;EP
NEW X,APCL,E,X,Y,%DT,BD,G
S X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes"
;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
NEW D,%DT K %DT S X=BDATE,%DT="P" D ^%DT S D=Y
NEW V,I,%
S %=""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V S G=$P(^AUPNVMED(V,0),U) I $P($G(^PSDRUG(G,0)),U,2)="CV800"!($P($G(^PSDRUG(G,0)),U,2)="CV805") S %=$P($P(^AUPNVSIT($P(^AUPNVMED(V,0),U,3),0),U),".")
I %]"" Q "Yes"
;refusals
NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'T Q "No"
S (G,X)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^APCLD817(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused or adverse reaction" ;cmi/maw 12/18/2007 DM2008
Q "No"_$S(G:" - Not Medically Indicated",1:"")
;
SELF(P,BDATE,EDATE) ;EP
NEW T,APCL,E,X,%DT,Y,ED,BD
S X=EDATE,%DT="P" D ^%DT S ED=Y
S X=BDATE,%DT="P" D ^%DT S BD=Y
S E=$$LASTHF^APCLD819(P,"DIABETES SELF MONITORING",BD,ED,"F")
I E]"" Q $S(E["YES":"Yes",E["NO":"No",E["REFUSED":"Refused",1:"")
S X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes"
Q "No"
SDM(P,BDATE,EDATE) ;EP
NEW T,APCL,E,X,%DT,Y,ED,BD
S X=EDATE,%DT="P" D ^%DT S ED=Y
S X=BDATE,%DT="P" D ^%DT S BD=Y
S E=$$LASTHF^APCLD819(P,"STAGED DIABETES MANAGEMENT",BD,ED)
I E Q "Yes"
S T=$O(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
I 'T Q ""
S %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
;check to see if one of the providers was the primary prov
NEW X,V,G,P,P1 S (G,X)=0 F S X=$O(APCL(X)) Q:X'=+X!(G) S V=$P(APCL(X),U,5) D
.S P=0 F S P=$O(^AUPNVPRV("AD",V,P)) Q:P'=+P!(G) S P1=$P(^AUPNVPRV(P,0),U) I $D(^ATXAX(T,21,"B",P1)) S G=1
.Q
Q $S(G:"Yes",1:"No")
;
ASPIRIN(P,BDATE,EDATE) ;EP
NEW X,APCL,E,A,N,G
S (A,B,G,N)=""
S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S A=1
K APCL S X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S N=1
;I A+N=2 Q "Both"
I A!(N) Q "Aspirin/Antiplatelet Rx"
;I N Q "Other"
;refusal oR NMI
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T Q "None"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^APCLD817(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "None - Not Medically Indicated"
NEW T S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
I 'T Q "None"
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^APCLD817(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
;I G,$P(G,U,2)'="N" Q "Refused"
I G Q "Refused or adverse rxn"
;NOW CHECK FOR ADVERSE REACTION/ALLERGY
S X=BDATE,%DT="P" D ^%DT S B=Y
D ASAALLEG(P,E,.APCLSAAL) ;return text of aspirin allergy if found
I $D(APCLSAAL(1)) Q "Refused or adverse rxn "_APCLSAAL(1)
Q "None"
;
TOBACCO(P,EDATE) ;EP
I '$G(P) Q ""
NEW B,D
NEW APCLTOB,APCL,X,E
D TOBACCO0
I $D(APCLTOB) Q APCLTOB
;D TOBACCO3
;I $D(APCLTOB) Q APCLTOB
D TOBACCO1 ;check Problem file for tobacco use
I $D(APCLTOB) Q APCLTOB
D TOBACCO2 ;check POVs for tobacco use
I $D(APCLTOB) Q APCLTOB
S X=$$DENT(P,APCLRBD,APCLRED)
I X]"" Q X
Q "3 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
K APCL S X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"_";DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
. I $P(APCL(1),U,3)["CURRENT"!($P(APCL(1),U,3)["CESS") S APCLTOB="1 Current User" Q
. S APCLTOB="2 Not a Current User "
.Q
Q
TOBACCO3 ;lookup in health status
S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
Q:'%
S X=0 K Y F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X I $D(^ATXAX(%,21,"B",X)) S D=$O(^AUPNHF("AA",P,X,0)),Y(9999999-D)=X
Q:'$D(Y)
S X=$O(Y(0))
S Y=Y(X)
S Y=$P(^AUTTHF(Y,0),U)
S APCLTOB=Y
I Y["CURRENT"!(Y["CESS") S APCLTOB="1 Current User" Q
S APCLTOB="2 Not a Current User"
Q
TOBACCO1 ;check problem file for tobacco use
K APCL S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/12/2007 orig line
. I $P($$ICDDX^ICDCODE($P(APCL(1),U,2)),U,2)=305.13 S APCLTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/12/2007 csv
. S APCLTOB="1 Current user - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30)
.Q
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
NEW D,%DT
S %DT="P",X=EDATE D ^%DT S D=Y
NEW BDATE S BDATE=$$FMADD^XLFDT(D,-365),BDATE=$$FMTE^XLFDT(BDATE)
K APCL S X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. I $P(APCL(1),U,2)=305.13 S APCLTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30) Q
. S APCLTOB="1 Current user"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30)
.Q
Q
DENT(P,BDATE,EDATE) ;EP
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G="1 Current user - Ada Code 1320 "
.Q
Q G
;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
I '$G(P) Q ""
NEW STR,TNAME,X,Y,%DT
S STR="",TNAME=""
S X=$$INSULIN^APCLD812(P,BD,EDATE)
I X]"" S STR=STR_"2"
S X=$$SULF^APCLD812(P,BD,EDATE)
I X]"" S STR=STR_3
S X=$$MET^APCLD812(P,BD,EDATE)
I X]"" S STR=STR_4
S X=$$ACAR^APCLD812(P,BD,EDATE)
I X]"" S STR=STR_5
S X=$$TROG^APCLD812(P,BD,EDATE)
I X]"" S STR=STR_"6"
S X=$$INCR^APCLD812(P,BD,EDATE) ;cmi/maw 12/26/2007 DM2008
I X]"" S STR=STR_7 ;cmi/maw 12/26/2007 DM2008
S X=$$DPP4^APCLD812(P,BD,EDATE) ;cmi/maw 12/26/2007 DM2008
I X]"" S STR=STR_8 ;cmi/maw 12/26/2007 DM2008
I STR]"" Q STR
S X=$$REFMED^APCLD812(P,BD,EDATE)
I X Q 9
Q 1
;
TYPE(P,R,EDATE) ;EP return type 1 or 2 for epi file
I '$G(P) Q ""
NEW TYPE S TYPE=""
I $G(R) S TYPE=$$CMSFDX^APCLD813(P,R,"DX")
I TYPE="NIDDM" Q 2
I TYPE["TYPE II" Q 2
I TYPE="IDDM" Q 1
I TYPE["2" Q 2
I TYPE["1" Q 1
S TYPE="" NEW X,I,C S X=$$PLDMDXS^APCLD813(P)
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") I $E(C,6)=0!($E(C,6)=2) S TYPE=2
I TYPE]"" Q TYPE
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") I $E(C,6)=1!($E(C,6)=3) S TYPE=1
I TYPE]"" Q TYPE
S X=$$LASTDMDX^APCLD813(P,EDATE)
I X[2 Q 2
I X[1 Q 1
Q ""
;
DURDM(P,R,EDATE) ;EP
I '$G(P) Q ""
NEW Y S Y=$$DODX(P,R,"I")
I Y="" Q ""
I 'Y Q ""
I Y>EDATE Q ""
;W !,$$HRN^AUPNPAT(P,DUZ(2)),"^",Y,"^",($$FMDIFF^XLFDT(EDATE,Y,1)\365)
Q $P(($$FMDIFF^XLFDT(EDATE,Y,1)\365.25),".")
DODX(P,R,F) ;EP - date of dx for epi file
I $G(F)="" S F="E"
NEW DATE,EARLY
S DATE="",EARLY=9999999
I $G(R) S DATE=$$CMSFDX^APCLD813(P,R,"ID")
I DATE S EARLY=DATE
S DATE=$$PLDMDOO^APCLD813(P,"I")
I DATE,DATE<EARLY S EARLY=DATE
I EARLY=9999999 S EARLY=""
Q $S(F="I":$$DI(EARLY),1:$$D(EARLY))
D(D) ;
I D="" Q ""
Q $S($E(D,4,5)="00":"07",1:$E(D,4,5))_"/"_$S($E(D,6,7)="00":"01",1:$E(D,6,7))_"/"_(1700+$E(D,1,3))
DI(D) ;EP
I D="" Q ""
Q $E(D,1,3)_$S($E(D,4,5)="00":"07",1:$E(D,4,5))_$S($E(D,6,7)="00":"01",1:$E(D,6,7))
;;
ASAALLEG(P,APCLD,APCLY) ;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,APCLG,APCLC,X,Y,Z,N
;APCLD is discharge date
S APCLC=0 K APCLY
S ED=$$FMADD^XLFDT(APCLD,-365)
ASAPOV ;
K APCLG S Y="APCLG(",X=P_"^ALL DX [APCL ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(APCLD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(APCLG(X)) Q:X'=+X S Y=+$P(APCLG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S APCLC=APCLC+1,APCLY(APCLC)="POV: "_$$FMTE^XLFDT($P(APCLG(X),U))_" ["_$P(APCLG(X),U,2)_"] "_N
.;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S APCLC=APCLC+1,APCLY(APCLC)="POV "_$$FMTE^XLFDT($P(APCLG(X),U))_" ["_$P(APCLG(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 APCLC=APCLC+1,APCLY(APCLC)="POV "_$$FMTE^XLFDT($P(APCLG(X),U))_" ["_$P(APCLG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 csv
.Q
K APCLG S Y="APCLG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(APCLD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(APCLG(X)) Q:X'=+X S Y=+$P(APCLG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["ASPIRIN"!(N["ASA") S APCLC=APCLC+1,APCLY(APCLC)="POV: "_$$FMTE^XLFDT($P(APCLG(X),U))_" ["_$P(APCLG(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)>APCLD ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S APCLC=APCLC+1,APCLY(APCLC)="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),".")>APCLD ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ASPIRIN" S APCLC=APCLC+1,APCLY(APCLC)="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
APCLD816 ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
+4 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW APCLJ,APCLI,X,APCLR
+2 SET APCLJ=""
+3 ;return computed TB Status Code
+4 SET X=$$TBTX^APCLD812(P)
+5 IF X]""
IF X["TX COMPLETE"
QUIT 1
+6 IF X]""
QUIT 2
+7 SET APCLR=$$PPD^APCLD818(P,EDATE)
+8 IF APCLR["POS"
Begin DoDot:1
+9 IF $$TBTX^APCLD812(P)["TX COMPLETE"
SET APCLJ=1
QUIT
+10 SET APCLJ=2
+11 QUIT
End DoDot:1
QUIT APCLJ
+12 IF APCLR["NEG"
SET APCLJ=4
Begin DoDot:1
+13 IF $$DODX(P,R,"I")=""
SET APCLJ=6
QUIT
+14 SET D=$$DODX(P,R,"I")
SET E=$$PPD^APCLD818(P,EDATE,"I")
SET APCLJ=$SELECT(D>E:4,1:3)
+15 QUIT
End DoDot:1
QUIT APCLJ
+16 IF APCLR["Unknown"
SET APCLJ=5
+17 IF APCLR["Refus"
SET APCLJ=7
+18 QUIT APCLJ
+19 ;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, placed on or after date of DM dx
4 ;;PPD -, placed before date of DM dx
5 ;;PPD Status unknown
6 ;;PPD -, date of DX or PPD date unknown
7 ;;PPD Refused
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/")+C
+6 QUIT C\3
+7 QUIT ""
DIAMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^APCLD813(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/",2)+C
+6 QUIT C\3
PPDDATE(P,EDATE) ;EP
+1 NEW X
SET X=$$LASTNP^APCLD818(P,EDATE)
+2 QUIT X
LIPID(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E,G,S,O
+2 SET (S,O,G)=""
SET X=P_"^MEDS [DM AUDIT LIPID LOWERING DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
SET O=1
+4 KILL APCL
+5 SET X=P_"^MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+6 IF $DATA(APCL(1))
SET S=1
+7 IF S
IF O
QUIT "Both"
+8 IF S
QUIT "Statin"
+9 IF O
QUIT "Other"
+10 ;refusal
+11 SET G=0
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
+13 IF 'T
QUIT "None"
+14 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^APCLD817(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
QUIT "Refused or Adverse Rxn"
+16 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
+17 IF 'T
GOTO LIPIDA
+18 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^APCLD817(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+19 IF G
QUIT "Refused or Adverse Rxn"
LIPIDA ;
+1 ;check patient allergies file for any with va drug class CV350
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET B=Y
+3 SET X=0
SET G=""
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>B
QUIT
+5 SET C=$ORDER(^PS(50.605,"B","CV350",0))
+6 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+7 ;I N["ASPIRIN" S APCLC=APCLC+1,APCLY(APCLC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N
+8 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
+9 ;S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
+10 ;I N["ASPIRIN" S APCLC=APCLC+1,APCLY(APCLC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+11 IF G]""
QUIT G
+12 QUIT "None"
+13 ;
+14 ;
ACE(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E,X,Y,%DT,BD,G
+2 SET X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes"
+4 ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
+5 NEW D,%DT
KILL %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET D=Y
+6 NEW V,I,%
+7 SET %=""
+8 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+9 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $PIECE($GET(^PSDRUG(G,0)),U,2)="CV800"!($PIECE($GET(^PSDRUG(G,0)),U,2)="CV805")
SET %=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(V,0),U,3),0),U),".")
End DoDot:1
+10 IF %]""
QUIT "Yes"
+11 ;refusals
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+13 IF 'T
QUIT "No"
+14 SET (G,X)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^APCLD817(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 ;cmi/maw 12/18/2007 DM2008
IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused or adverse reaction"
+16 QUIT "No"_$SELECT(G:" - Not Medically Indicated",1:"")
+17 ;
SELF(P,BDATE,EDATE) ;EP
+1 NEW T,APCL,E,X,%DT,Y,ED,BD
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET E=$$LASTHF^APCLD819(P,"DIABETES SELF MONITORING",BD,ED,"F")
+5 IF E]""
QUIT $SELECT(E["YES":"Yes",E["NO":"No",E["REFUSED":"Refused",1:"")
+6 SET X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+7 IF $DATA(APCL(1))
QUIT "Yes"
+8 QUIT "No"
SDM(P,BDATE,EDATE) ;EP
+1 NEW T,APCL,E,X,%DT,Y,ED,BD
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET E=$$LASTHF^APCLD819(P,"STAGED DIABETES MANAGEMENT",BD,ED)
+5 IF E
QUIT "Yes"
+6 SET T=$ORDER(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
+7 IF 'T
QUIT ""
+8 SET %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+9 ;check to see if one of the providers was the primary prov
+10 NEW X,V,G,P,P1
SET (G,X)=0
FOR
SET X=$ORDER(APCL(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(APCL(X),U,5)
Begin DoDot:1
+11 SET P=0
FOR
SET P=$ORDER(^AUPNVPRV("AD",V,P))
IF P'=+P!(G)
QUIT
SET P1=$PIECE(^AUPNVPRV(P,0),U)
IF $DATA(^ATXAX(T,21,"B",P1))
SET G=1
+12 QUIT
End DoDot:1
+13 QUIT $SELECT(G:"Yes",1:"No")
+14 ;
ASPIRIN(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E,A,N,G
+2 SET (A,B,G,N)=""
+3 SET X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+4 IF $DATA(APCL(1))
SET A=1
+5 KILL APCL
SET X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+6 IF $DATA(APCL(1))
SET N=1
+7 ;I A+N=2 Q "Both"
+8 IF A!(N)
QUIT "Aspirin/Antiplatelet Rx"
+9 ;I N Q "Other"
+10 ;refusal oR NMI
+11 SET G=0
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+13 IF 'T
QUIT "None"
+14 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^APCLD817(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+16 IF G
QUIT "None - Not Medically Indicated"
+17 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+18 IF 'T
QUIT "None"
+19 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^APCLD817(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+20 ;I G,$P(G,U,2)'="N" Q "Refused"
+21 IF G
QUIT "Refused or adverse rxn"
+22 ;NOW CHECK FOR ADVERSE REACTION/ALLERGY
+23 SET X=BDATE
SET %DT="P"
DO ^%DT
SET B=Y
+24 ;return text of aspirin allergy if found
DO ASAALLEG(P,E,.APCLSAAL)
+25 IF $DATA(APCLSAAL(1))
QUIT "Refused or adverse rxn "_APCLSAAL(1)
+26 QUIT "None"
+27 ;
TOBACCO(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW B,D
+3 NEW APCLTOB,APCL,X,E
+4 DO TOBACCO0
+5 IF $DATA(APCLTOB)
QUIT APCLTOB
+6 ;D TOBACCO3
+7 ;I $D(APCLTOB) Q APCLTOB
+8 ;check Problem file for tobacco use
DO TOBACCO1
+9 IF $DATA(APCLTOB)
QUIT APCLTOB
+10 ;check POVs for tobacco use
DO TOBACCO2
+11 IF $DATA(APCLTOB)
QUIT APCLTOB
+12 SET X=$$DENT(P,APCLRBD,APCLRED)
+13 IF X]""
QUIT X
+14 QUIT "3 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
+1 ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
KILL APCL
SET X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"_";DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+2 IF $PIECE(APCL(1),U,3)["CURRENT"!($PIECE(APCL(1),U,3)["CESS")
SET APCLTOB="1 Current User"
QUIT
+3 SET APCLTOB="2 Not a Current User "
+4 QUIT
End DoDot:1
+5 QUIT
TOBACCO3 ;lookup in health status
+1 SET %=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
+2 IF '%
QUIT
+3 SET X=0
KILL Y
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET D=$ORDER(^AUPNHF("AA",P,X,0))
SET Y(9999999-D)=X
+4 IF '$DATA(Y)
QUIT
+5 SET X=$ORDER(Y(0))
+6 SET Y=Y(X)
+7 SET Y=$PIECE(^AUTTHF(Y,0),U)
+8 SET APCLTOB=Y
+9 IF Y["CURRENT"!(Y["CESS")
SET APCLTOB="1 Current User"
QUIT
+10 SET APCLTOB="2 Not a Current User"
+11 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL APCL
SET X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+2 ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/12/2007 orig line
+3 ;cmi/anch/maw 9/12/2007 csv
IF $PIECE($$ICDDX^ICDCODE($PIECE(APCL(1),U,2)),U,2)=305.13
SET APCLTOB="2 Not a Current User"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30)
QUIT
+4 SET APCLTOB="1 Current user - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30)
+5 QUIT
End DoDot:1
+6 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 NEW D,%DT
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET D=Y
+3 NEW BDATE
SET BDATE=$$FMADD^XLFDT(D,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
+4 KILL APCL
SET X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+5 IF $PIECE(APCL(1),U,2)=305.13
SET APCLTOB="2 Not a Current User"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30)
QUIT
+6 SET APCLTOB="1 Current user"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30)
+7 QUIT
End DoDot:1
+8 QUIT
DENT(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB,"A")
+2 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+3 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+8 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET G="1 Current user - Ada Code 1320 "
+9 QUIT
End DoDot:1
+10 QUIT G
+11 ;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
+1 IF '$GET(P)
QUIT ""
+2 NEW STR,TNAME,X,Y,%DT
+3 SET STR=""
SET TNAME=""
+4 SET X=$$INSULIN^APCLD812(P,BD,EDATE)
+5 IF X]""
SET STR=STR_"2"
+6 SET X=$$SULF^APCLD812(P,BD,EDATE)
+7 IF X]""
SET STR=STR_3
+8 SET X=$$MET^APCLD812(P,BD,EDATE)
+9 IF X]""
SET STR=STR_4
+10 SET X=$$ACAR^APCLD812(P,BD,EDATE)
+11 IF X]""
SET STR=STR_5
+12 SET X=$$TROG^APCLD812(P,BD,EDATE)
+13 IF X]""
SET STR=STR_"6"
+14 ;cmi/maw 12/26/2007 DM2008
SET X=$$INCR^APCLD812(P,BD,EDATE)
+15 ;cmi/maw 12/26/2007 DM2008
IF X]""
SET STR=STR_7
+16 ;cmi/maw 12/26/2007 DM2008
SET X=$$DPP4^APCLD812(P,BD,EDATE)
+17 ;cmi/maw 12/26/2007 DM2008
IF X]""
SET STR=STR_8
+18 IF STR]""
QUIT STR
+19 SET X=$$REFMED^APCLD812(P,BD,EDATE)
+20 IF X
QUIT 9
+21 QUIT 1
+22 ;
TYPE(P,R,EDATE) ;EP return type 1 or 2 for epi file
+1 IF '$GET(P)
QUIT ""
+2 NEW TYPE
SET TYPE=""
+3 IF $GET(R)
SET TYPE=$$CMSFDX^APCLD813(P,R,"DX")
+4 IF TYPE="NIDDM"
QUIT 2
+5 IF TYPE["TYPE II"
QUIT 2
+6 IF TYPE="IDDM"
QUIT 1
+7 IF TYPE["2"
QUIT 2
+8 IF TYPE["1"
QUIT 1
+9 SET TYPE=""
NEW X,I,C
SET X=$$PLDMDXS^APCLD813(P)
+10 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
IF $EXTRACT(C,6)=0!($EXTRACT(C,6)=2)
SET TYPE=2
+11 IF TYPE]""
QUIT TYPE
+12 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
IF $EXTRACT(C,6)=1!($EXTRACT(C,6)=3)
SET TYPE=1
+13 IF TYPE]""
QUIT TYPE
+14 SET X=$$LASTDMDX^APCLD813(P,EDATE)
+15 IF X[2
QUIT 2
+16 IF X[1
QUIT 1
+17 QUIT ""
+18 ;
DURDM(P,R,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW Y
SET Y=$$DODX(P,R,"I")
+3 IF Y=""
QUIT ""
+4 IF 'Y
QUIT ""
+5 IF Y>EDATE
QUIT ""
+6 ;W !,$$HRN^AUPNPAT(P,DUZ(2)),"^",Y,"^",($$FMDIFF^XLFDT(EDATE,Y,1)\365)
+7 QUIT $PIECE(($$FMDIFF^XLFDT(EDATE,Y,1)\365.25),".")
DODX(P,R,F) ;EP - date of dx for epi file
+1 IF $GET(F)=""
SET F="E"
+2 NEW DATE,EARLY
+3 SET DATE=""
SET EARLY=9999999
+4 IF $GET(R)
SET DATE=$$CMSFDX^APCLD813(P,R,"ID")
+5 IF DATE
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^APCLD813(P,"I")
+7 IF DATE
IF DATE<EARLY
SET EARLY=DATE
+8 IF EARLY=9999999
SET EARLY=""
+9 QUIT $SELECT(F="I":$$DI(EARLY),1:$$D(EARLY))
D(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $SELECT($EXTRACT(D,4,5)="00":"07",1:$EXTRACT(D,4,5))_"/"_$SELECT($EXTRACT(D,6,7)="00":"01",1:$EXTRACT(D,6,7))_"/"_(1700+$EXTRACT(D,1,3))
DI(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,1,3)_$SELECT($EXTRACT(D,4,5)="00":"07",1:$EXTRACT(D,4,5))_$SELECT($EXTRACT(D,6,7)="00":"01",1:$EXTRACT(D,6,7))
+3 ;;
ASAALLEG(P,APCLD,APCLY) ;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,APCLG,APCLC,X,Y,Z,N
+3 ;APCLD is discharge date
+4 SET APCLC=0
KILL APCLY
+5 SET ED=$$FMADD^XLFDT(APCLD,-365)
ASAPOV ;
+1 KILL APCLG
SET Y="APCLG("
SET X=P_"^ALL DX [APCL ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(APCLD)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(APCLG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(APCLG(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 APCLC=APCLC+1
SET APCLY(APCLC)="POV: "_$$FMTE^XLFDT($PIECE(APCLG(X),U))_" ["_$PIECE(APCLG(X),U,2)_"] "_N
+5 ;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S APCLC=APCLC+1,APCLY(APCLC)="POV "_$$FMTE^XLFDT($P(APCLG(X),U))_" ["_$P(APCLG(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 APCLC=APCLC+1
SET APCLY(APCLC)="POV "_$$FMTE^XLFDT($PIECE(APCLG(X),U))_" ["_$PIECE(APCLG(X),U,2)_" + E935.3] "_N
+7 QUIT
End DoDot:1
+8 KILL APCLG
SET Y="APCLG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(APCLD)
SET E=$$START1^APCLDF(X,Y)
+9 SET X=0
FOR
SET X=$ORDER(APCLG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(APCLG(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 APCLC=APCLC+1
SET APCLY(APCLC)="POV: "_$$FMTE^XLFDT($PIECE(APCLG(X),U))_" ["_$PIECE(APCLG(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)>APCLD
QUIT
+20 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET APCLC=APCLC+1
SET APCLY(APCLC)="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 discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>APCLD
QUIT
+25 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+26 IF N["ASPIRIN"
SET APCLC=APCLC+1
SET APCLY(APCLC)="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
