APCHS9B4 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;2.0;IHS PCC SUITE;**2,5,11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 8/27/2007 code set versioning in HYSTER, EYE
;
FRSTDMDX(P,F) ;EP return date of first dm dx
I $G(F)="" S F="E"
I '$G(P) Q ""
NEW X,E,APCHS,Y
S Y="APCHS("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(APCHS(1)),U)
Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)
CMSFDX(P,F) ;EP - return date/dx of dm in register
I $G(F)="" S F="E"
I '$G(P) Q ""
;NEW R S R=$O(^ACM(41.1,"B","IHS DIABETES",0)) I 'R Q ""
NEW R,N,D,D1,Y,X,G S R=0,N="",D="" F S N=$O(^ACM(41.1,"B",N)) Q:N=""!(D]"") S R=0 F S R=$O(^ACM(41.1,"B",N,R)) Q:R'=+R!(D]"") I N["DIAB" D
.S (G,X)=0,(D,Y)="" F S X=$O(^ACM(44,"C",P,X)) Q:X'=+X!(D]"") I $P(^ACM(44,X,0),U,4)=R D
..S D=$P($G(^ACM(44,X,"SV")),U,2) I D]"" S D1=D,D=$S(F="E":$$FMTE^XLFDT(D),1:D)
Q $G(D)
;
PLDMDOO(P,F) ;EP get first dm dx from case management
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)'="D"
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^ATXAPI(I,T,9) D
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
..Q
.Q
S D=$O(D(0))
I D="" Q D
Q $S(F="E":$$FMTE^XLFDT(D),1:D)
DNKA(V) ;EP is this a DNKA visit?
I '$G(V) Q ""
NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
REFR(V) ;
I '$G(V) Q ""
NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
I D="367.89"!(D="367.9") Q 1
Q 0
DFE(P,APCHSED) ;EP
NEW APCHY,APCHV,%,LDFE S LDFE="",%=P_"^LAST EXAM DIABETIC FOOT EXAM",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LDFE=$P(APCHY(1),U)
I $D(APCHY(1)),$P(APCHY(1),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))_" (Diabetic Foot Exam, Complete)" Q APCHX
;now check any clinic 65 or prov 33/25
K APCHY,APCHV
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHY(")
;reorder by date of visit/reverse order
S %=0 F S %=$O(APCHY(%)) Q:%'=+% S APCHV(9999999-$P(APCHY(%),U),$P(APCHY(%),U,5))=""
N PROV,D,V,G S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$PRIMPROV^APCLV(V,"D") I (PROV=33!(PROV=25)),'$$DNKA(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Podiatrist)"
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$CLINIC^APCLV(V,"C") I PROV=65!(PROV="B7"),'$$DNKA(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Podiatry Clinic)"
S G=$$REFDF^APCHS9B3(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),$G(LDFE))
I G]"" Q G
Q "No "_$S($D(LDFE):$$FMTE^XLFDT(LDFE),1:"")
;
EYE(P,APCHSED) ;EP
NEW APCHY,LDEE,%,APCHEX S APCHEX=0 S LDEE="",%=P_"^LAST EXAM DIABETIC EYE EXAM",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LDEE=$P(APCHY(1),U),APCHEX=+$P(APCHY(1),U,4)
I $P($G(APCHY(1)),U)'<APCHSED S APCHX="Yes "_$$FMTE^XLFDT($P(APCHY(1),U))_" (Diabetic Eye Exam) result: "_$P($$VAL^XBDIQ1(9000010.13,+$P(APCHY(1),U,4),.04),"/",1) Q APCHX
K APCHY S APCHCPT=""
NEW T,C,APCHCPT,APCHCPT1
F C=92250,92012,92014,92004,92002 S T=$O(^ICPT("B",C,0)) D
.I T S APCHY=$O(^AUPNVCPT("AA",P,T,0)) I APCHY D ;I APCHY D I APCHY'<APCHSED Q "Yes "_$$FMTE^XLFDT(APCHY)_" (Fundus Photography)"
..S APCHY=9999999-APCHY
..I LDEE<APCHY S LDEE=APCHY,APCHEX=0,APCHCPT=T,APCHCPT1=C
;I LDEE,LDEE'<APCHSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_APCHCPT1_"-"_$E($P(^ICPT(APCHCPT,0),U,2),1,28)_")" ;cmi/anch/maw 8/28/2007 orig line
I LDEE,LDEE'<APCHSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_APCHCPT1_"-"_$E($P($$CPT^ICPTCOD(APCHCPT,LDEE),U,3),1,28)_")" ;cmi/anch/maw 8/28/2007 code set versioning
;now check any clinic 17 or 18
K APCHY,APCHV
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"APCHY(")
;reorder by date of visit/reverse order
S %=0 F S %=$O(APCHY(%)) Q:%'=+% S APCHV(9999999-$P(APCHY(%),U),$P(APCHY(%),U,5))=""
N PROV,D,V,G
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$PRIMPROV^APCLV(V,"D") I (PROV=24!(PROV=79)!(PROV="08")),'$$DNKA(V),'$$REFR(V),$P(^AUPNVSIT(V,0),U,9) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Ophthalmologist or Optometrist Visit)"
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$CLINIC^APCLV(V,"C") I (PROV=17!(PROV=18)!(PROV=64)),'$$DNKA(V),'$$REFR(V),$P(^AUPNVSIT(V,0),U,9) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Optometry or Ophthalmology Clinic)"
S G=$$REFDF^APCHS9B3(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),$G(LDEE))
I G]"" Q G
S %="No "_$S($D(LDEE):$$FMTE^XLFDT(LDEE),1:"")
I APCHEX S %=%_" (Diabetic Eye Exam) result: "_$P($$VAL^XBDIQ1(9000010.13,APCHEX,.04),"/",1)
Q %
PAP(P,APCHSED) ;EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
S LPAP=$$LASTPAP^APCLAPI1(P)
S G=$$REFDF^APCHS9B3(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$G(LPAP))
I G]"" Q $G(LPAP)_"^"_G
Q $G(LPAP)
OLDPAP ;
;NEW APCHY S APCHY=$$HYSTER(APCHSDFN,DT) I APCHY]"" Q APCHY
NEW APCHY,%,LPAP S LPAP="",%=P_"^LAST LAB PAP SMEAR",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LPAP=$P(APCHY(1),U)
NEW APCHY,%,LPAP S LPAP="",%=P_"^LAST LAB [BGP PAP SMEAR TAX",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LPAP=$P(APCHY(1),U)
;get last pap smear via loinc code
S APCHLT=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
I APCHLT D
.S D=0,G="" F S D=$O(^AUPNVLAB("AE",P,D)) Q:D=""!(G]"") D
..S T=0 F S T=$O(^AUPNVLAB("AE",P,D,T)) Q:T=""!(G]"") D
...S I=0 F S I=$O(^AUPNVLAB("AE",P,D,T,I)) Q:I=""!(G]"") D
....Q:'$D(^AUPNVLAB(I,0))
....S J=$P($G(^AUPNVLAB(I,11)),U,13)
....Q:J=""
....Q:'$$LOINC^APCHS9B2(J,APCHLT)
....S V=$P(^AUPNVLAB(I,0),U,3)
....S G=$P($P($G(^AUPNVSIT(V,0)),U),".")
....Q
I G]"" D
.Q:LPAP>G
.S LPAP=G
K APCHY S %=P_"^LAST DX V76.2",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
K APCHY S %=P_"^LAST PROCEDURE 91.46",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
K APCHY NEW % F %=1:1 S T=$T(PAPCPTS+%^APCHSMU) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S APCHY(1)=$O(^AUPNVCPT("AA",P,T,0)) I APCHY(1) S APCHY(1)=9999999-APCHY(1) D
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T S X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),DT,T,3)
I X]"" D
.Q:LPAP>X
.S LPAP=X
S G=$$REFDF^APCHS9B3(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$G(LPAP))
I G]"" Q $G(LPAP)_"^"_G
Q $G(LPAP)
;
MAMREF(P,LMAM) ;EP
NEW G,APCHY
S G=""
K APCHY S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",76090,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",76091,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",76092,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
K APCHY S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",77055,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",77056,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",77057,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
K APCHY S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",77058,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",77059,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D","G0202",APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
K APCHY S APCHY=0 F S APCHY=$O(^RAMIS(71,"D","G0204",APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D","G0206",APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q G
Q $G(LMAM)
;
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
;cmi/anch/maw 8/27/2007 mods for code set versioning
N APCHSVDT
S F=0,S="" F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S APCHSVDT=$P(+^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),"."),C=$P($$ICDOP^ICDEX(+^AUPNVPRC(F,0),APCHSVDT,,"I"),U,2) D
.;cmi/anch/maw 8/27/2007 end of mods
.S G=0 S:(C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9) G=C
.Q:G=0
.S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
.;I D>EDATE Q
.S S=1
I S]"" Q "Pt had Hysterectomy on "_$$FMTE^XLFDT(D,2)_" procedure: "_G
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X]"" Q "Hysterectomy documented in Women's Health: "_$$FMTE^XLFDT(X,2)
.S X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),EDATE,T,3)
S T=$O(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
I T D I X]"" Q "Pt had Hysterectomy on "_$$FMTE^XLFDT($P(X,U),2)_" CPT: "_$P(X,U,2)
.S X=$$CPT^APCHSMU2(P,$P(^DPT(P,0),U,3),EDATE,T,5)
Q ""
APCHS9B4 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;2.0;IHS PCC SUITE;**2,5,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 8/27/2007 code set versioning in HYSTER, EYE
+4 ;
FRSTDMDX(P,F) ;EP return date of first dm dx
+1 IF $GET(F)=""
SET F="E"
+2 IF '$GET(P)
QUIT ""
+3 NEW X,E,APCHS,Y
+4 SET Y="APCHS("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(APCHS(1)),U)
+6 QUIT $SELECT(F="E":$$FMTE^XLFDT(Y),1:Y)
CMSFDX(P,F) ;EP - return date/dx of dm in register
+1 IF $GET(F)=""
SET F="E"
+2 IF '$GET(P)
QUIT ""
+3 ;NEW R S R=$O(^ACM(41.1,"B","IHS DIABETES",0)) I 'R Q ""
+4 NEW R,N,D,D1,Y,X,G
SET R=0
SET N=""
SET D=""
FOR
SET N=$ORDER(^ACM(41.1,"B",N))
IF N=""!(D]"")
QUIT
SET R=0
FOR
SET R=$ORDER(^ACM(41.1,"B",N,R))
IF R'=+R!(D]"")
QUIT
IF N["DIAB"
Begin DoDot:1
+5 SET (G,X)=0
SET (D,Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X!(D]"")
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:2
+6 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
IF D]""
SET D1=D
SET D=$SELECT(F="E":$$FMTE^XLFDT(D),1:D)
End DoDot:2
End DoDot:1
+7 QUIT $GET(D)
+8 ;
PLDMDOO(P,F) ;EP get first dm dx from case management
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
QUIT
+7 SET I=$PIECE(^AUPNPROB(X,0),U)
+8 IF $$ICD^ATXAPI(I,T,9)
Begin DoDot:2
+9 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET D=$ORDER(D(0))
+13 IF D=""
QUIT D
+14 QUIT $SELECT(F="E":$$FMTE^XLFDT(D),1:D)
DNKA(V) ;EP is this a DNKA visit?
+1 IF '$GET(V)
QUIT ""
+2 NEW D,N
SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
REFR(V) ;
+1 IF '$GET(V)
QUIT ""
+2 NEW D,N
SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D="367.89"!(D="367.9")
QUIT 1
+4 QUIT 0
DFE(P,APCHSED) ;EP
+1 NEW APCHY,APCHV,%,LDFE
SET LDFE=""
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM"
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF $DATA(APCHY(1))
SET LDFE=$PIECE(APCHY(1),U)
+3 IF $DATA(APCHY(1))
IF $PIECE(APCHY(1),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))_" (Diabetic Foot Exam, Complete)"
QUIT APCHX
+4 ;now check any clinic 65 or prov 33/25
+5 KILL APCHY,APCHV
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHY(")
+7 ;reorder by date of visit/reverse order
+8 SET %=0
FOR
SET %=$ORDER(APCHY(%))
IF %'=+%
QUIT
SET APCHV(9999999-$PIECE(APCHY(%),U),$PIECE(APCHY(%),U,5))=""
+9 NEW PROV,D,V,G
SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$PRIMPROV^APCLV(V,"D")
IF (PROV=33!(PROV=25))
IF '$$DNKA(V)
SET G=9999999-D
+10 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Podiatrist)"
+11 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$CLINIC^APCLV(V,"C")
IF PROV=65!(PROV="B7")
IF '$$DNKA(V)
SET G=9999999-D
+12 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Podiatry Clinic)"
+13 SET G=$$REFDF^APCHS9B3(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),$GET(LDFE))
+14 IF G]""
QUIT G
+15 QUIT "No "_$SELECT($DATA(LDFE):$$FMTE^XLFDT(LDFE),1:"")
+16 ;
EYE(P,APCHSED) ;EP
+1 NEW APCHY,LDEE,%,APCHEX
SET APCHEX=0
SET LDEE=""
SET %=P_"^LAST EXAM DIABETIC EYE EXAM"
SET E=$$START1^APCLDF(%,"APCHY(")
+2 IF $DATA(APCHY(1))
SET LDEE=$PIECE(APCHY(1),U)
SET APCHEX=+$PIECE(APCHY(1),U,4)
+3 IF $PIECE($GET(APCHY(1)),U)'<APCHSED
SET APCHX="Yes "_$$FMTE^XLFDT($PIECE(APCHY(1),U))_" (Diabetic Eye Exam) result: "_$PIECE($$VAL^XBDIQ1(9000010.13,+$PIECE(APCHY(1),U,4),.04),"/",1)
QUIT APCHX
+4 KILL APCHY
SET APCHCPT=""
+5 NEW T,C,APCHCPT,APCHCPT1
+6 FOR C=92250,92012,92014,92004,92002
SET T=$ORDER(^ICPT("B",C,0))
Begin DoDot:1
+7 ;I APCHY D I APCHY'<APCHSED Q "Yes "_$$FMTE^XLFDT(APCHY)_" (Fundus Photography)"
IF T
SET APCHY=$ORDER(^AUPNVCPT("AA",P,T,0))
IF APCHY
Begin DoDot:2
+8 SET APCHY=9999999-APCHY
+9 IF LDEE<APCHY
SET LDEE=APCHY
SET APCHEX=0
SET APCHCPT=T
SET APCHCPT1=C
End DoDot:2
End DoDot:1
+10 ;I LDEE,LDEE'<APCHSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_APCHCPT1_"-"_$E($P(^ICPT(APCHCPT,0),U,2),1,28)_")" ;cmi/anch/maw 8/28/2007 orig line
+11 ;cmi/anch/maw 8/28/2007 code set versioning
IF LDEE
IF LDEE'<APCHSED
QUIT "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_APCHCPT1_"-"_$EXTRACT($PIECE($$CPT^ICPTCOD(APCHCPT,LDEE),U,3),1,28)_")"
+12 ;now check any clinic 17 or 18
+13 KILL APCHY,APCHV
+14 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"APCHY(")
+15 ;reorder by date of visit/reverse order
+16 SET %=0
FOR
SET %=$ORDER(APCHY(%))
IF %'=+%
QUIT
SET APCHV(9999999-$PIECE(APCHY(%),U),$PIECE(APCHY(%),U,5))=""
+17 NEW PROV,D,V,G
+18 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$PRIMPROV^APCLV(V,"D")
IF (PROV=24!(PROV=79)!(PROV="08"))
IF '$$DNKA(V)
IF '$$REFR(V)
IF $PIECE(^AUPNVSIT(V,0),U,9)
SET G=9999999-D
+19 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Ophthalmologist or Optometrist Visit)"
+20 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$CLINIC^APCLV(V,"C")
IF (PROV=17!(PROV=18)!(PROV=64))
IF '$$DNKA(V)
IF '$$REFR(V)
IF $PIECE(^AUPNVSIT(V,0),U,9)
SET G=9999999-D
+21 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Optometry or Ophthalmology Clinic)"
+22 SET G=$$REFDF^APCHS9B3(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),$GET(LDEE))
+23 IF G]""
QUIT G
+24 SET %="No "_$SELECT($DATA(LDEE):$$FMTE^XLFDT(LDEE),1:"")
+25 IF APCHEX
SET %=%_" (Diabetic Eye Exam) result: "_$PIECE($$VAL^XBDIQ1(9000010.13,APCHEX,.04),"/",1)
+26 QUIT %
PAP(P,APCHSED) ;EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 SET LPAP=$$LASTPAP^APCLAPI1(P)
+3 SET G=$$REFDF^APCHS9B3(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$GET(LPAP))
+4 IF G]""
QUIT $GET(LPAP)_"^"_G
+5 QUIT $GET(LPAP)
OLDPAP ;
+1 ;NEW APCHY S APCHY=$$HYSTER(APCHSDFN,DT) I APCHY]"" Q APCHY
+2 NEW APCHY,%,LPAP
SET LPAP=""
SET %=P_"^LAST LAB PAP SMEAR"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF $DATA(APCHY(1))
SET LPAP=$PIECE(APCHY(1),U)
+4 NEW APCHY,%,LPAP
SET LPAP=""
SET %=P_"^LAST LAB [BGP PAP SMEAR TAX"
SET E=$$START1^APCLDF(%,"APCHY(")
+5 IF $DATA(APCHY(1))
SET LPAP=$PIECE(APCHY(1),U)
+6 ;get last pap smear via loinc code
+7 SET APCHLT=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+8 IF APCHLT
Begin DoDot:1
+9 SET D=0
SET G=""
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+10 SET T=0
FOR
SET T=$ORDER(^AUPNVLAB("AE",P,D,T))
IF T=""!(G]"")
QUIT
Begin DoDot:3
+11 SET I=0
FOR
SET I=$ORDER(^AUPNVLAB("AE",P,D,T,I))
IF I=""!(G]"")
QUIT
Begin DoDot:4
+12 IF '$DATA(^AUPNVLAB(I,0))
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(I,11)),U,13)
+14 IF J=""
QUIT
+15 IF '$$LOINC^APCHS9B2(J,APCHLT)
QUIT
+16 SET V=$PIECE(^AUPNVLAB(I,0),U,3)
+17 SET G=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+18 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF G]""
Begin DoDot:1
+20 IF LPAP>G
QUIT
+21 SET LPAP=G
End DoDot:1
+22 KILL APCHY
SET %=P_"^LAST DX V76.2"
SET E=$$START1^APCLDF(%,"APCHY(")
+23 IF $DATA(APCHY(1))
Begin DoDot:1
+24 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+25 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+26 KILL APCHY
SET %=P_"^LAST PROCEDURE 91.46"
SET E=$$START1^APCLDF(%,"APCHY(")
+27 IF $DATA(APCHY(1))
Begin DoDot:1
+28 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+29 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+30 KILL APCHY
NEW %
FOR %=1:1
SET T=$TEXT(PAPCPTS+%^APCHSMU)
IF $PIECE(T,";;",2)=""
QUIT
SET T=$PIECE(T,";;",2)
SET T=$ORDER(^ICPT("B",T,0))
IF T
SET APCHY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
IF APCHY(1)
SET APCHY(1)=9999999-APCHY(1)
Begin DoDot:1
+31 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+32 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+33 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+34 IF T
SET X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),DT,T,3)
+35 IF X]""
Begin DoDot:1
+36 IF LPAP>X
QUIT
+37 SET LPAP=X
End DoDot:1
+38 SET G=$$REFDF^APCHS9B3(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$GET(LPAP))
+39 IF G]""
QUIT $GET(LPAP)_"^"_G
+40 QUIT $GET(LPAP)
+41 ;
MAMREF(P,LMAM) ;EP
+1 NEW G,APCHY
+2 SET G=""
+3 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76090,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+4 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+5 IF G]""
QUIT G
+6 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76091,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+7 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+8 IF G]""
QUIT G
+9 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76092,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+10 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+11 IF G]""
QUIT G
+12 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77055,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+13 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+14 IF G]""
QUIT G
+15 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77056,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+16 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+17 IF G]""
QUIT G
+18 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77057,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+19 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+20 IF G]""
QUIT G
+21 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77058,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+22 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+23 IF G]""
QUIT G
+24 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77059,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+25 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+26 IF G]""
QUIT G
+27 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0202",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+28 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+29 IF G]""
QUIT G
+30 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0204",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+31 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+32 IF G]""
QUIT G
+33 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0206",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+34 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+35 IF G]""
QUIT G
+36 QUIT $GET(LMAM)
+37 ;
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;cmi/anch/maw 8/27/2007 mods for code set versioning
+3 NEW APCHSVDT
+4 SET F=0
SET S=""
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET APCHSVDT=$PIECE(+^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),".")
SET C=$PIECE($$ICDOP^ICDEX(+^AUPNVPRC(F,0),APCHSVDT,,"I"),U,2)
Begin DoDot:1
+5 ;cmi/anch/maw 8/27/2007 end of mods
+6 SET G=0
IF (C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9)
SET G=C
+7 IF G=0
QUIT
+8 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+9 ;I D>EDATE Q
+10 SET S=1
End DoDot:1
+11 IF S]""
QUIT "Pt had Hysterectomy on "_$$FMTE^XLFDT(D,2)_" procedure: "_G
+12 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+13 IF T
Begin DoDot:1
+14 SET X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),EDATE,T,3)
End DoDot:1
IF X]""
QUIT "Hysterectomy documented in Women's Health: "_$$FMTE^XLFDT(X,2)
+15 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+16 IF T
Begin DoDot:1
+17 SET X=$$CPT^APCHSMU2(P,$PIECE(^DPT(P,0),U,3),EDATE,T,5)
End DoDot:1
IF X]""
QUIT "Pt had Hysterectomy on "_$$FMTE^XLFDT($PIECE(X,U),2)_" CPT: "_$PIECE(X,U,2)
+18 QUIT ""
