BHSDM4 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:24;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9,12**;March 17, 2006;Build 3
;===================================================================
;VA version of IHS components for supplemental summaries
;Taken from APCHS9B4
; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 05/10/04 6:07 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,5,6,7,8,10,11,12**;JUN 24, 1997
;Patch 1001 to bring up to patch 15
;Patch 2, code set versioning
;Patch 12, use new API for taxonomies
;===================================================================
FRSTDMDX(P,F) ;EP return date of first dm dx
I $G(F)="" S F="E"
I '$G(P) Q ""
NEW X,E,BHSS,Y
S Y="BHSS("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BHSS(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,TAXARR
;IHS/MSC/MGH Moved taxonomy lookup out of loop
S TAXARR=""
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
.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,BHSSED) ;EP
NEW BHSY,BHSV,%,LDFE S LDFE="",%=P_"^LAST EXAM DIABETIC FOOT EXAM",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LDFE=$P(BHSY(1),U)
I $D(BHSY(1)),$P(BHSY(1),U)'<BHSSED S BHSX="Yes "_$$FMTE^XLFDT($P(BHSY(1),U))_" (Diabetic Foot Exam, Complete)" Q BHSX
;now check any clinic 65 or prov 33/25
K BHSY,BHSV
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BHSSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"BHSY(")
;reorder by date of visit/reverse order
S %=0 F S %=$O(BHSY(%)) Q:%'=+% S BHSV(9999999-$P(BHSY(%),U),$P(BHSY(%),U,5))=""
N PROV,D,V,G S (D,V)=0,G="" F S D=$O(BHSV(D)) Q:D'=+D!(G) S V=0 F S V=$O(BHSV(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(BHSV(D)) Q:D'=+D!(G) S V=0 F S V=$O(BHSV(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^BHSDM3(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,BHSSED) ;EP
NEW BHSY,LDEE,%,BHSEX S BHSEX=0 S LDEE="",%=P_"^LAST EXAM DIABETIC EYE EXAM",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LDEE=$P(BHSY(1),U),BHSEX=+$P(BHSY(1),U,4)
I $P($G(BHSY(1)),U)'<BHSSED S BHSX="Yes "_$$FMTE^XLFDT($P(BHSY(1),U))_" (Diabetic Eye Exam)" Q BHSX
K BHSY S BHSCPT=""
NEW T,C,BHSCPT,BHSCPT1
;PATCH UPDATES
F C=992250,92012,92014,92004,92002 S T=$O(^ICPT("B",C,0)) D
.I T S BHSY=$O(^AUPNVCPT("AA",P,T,0)) I BHSY D
..S BHSY=9999999-BHSY
..I LDEE<BHSY S LDEE=BHSY,BHSEX=0,BHSCPT=T,BHSCPT1=C
;I LDEE,LDEE'<BHSSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_BHSCPT1_"-"_$E($P(^ICPT(BHSCPT,0),U,2),1,28)_")"
I LDEE,LDEE'<BHSSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_BHSCPT1_"-"_$E($P($$CPT^ICPTCOD(BHSCPT,LDEE),U,3),1,28)_")" ;code set versioning cmi/anch/maw 8/2
;END PATCH UPDATES
;now check any clinic 17 or 18
K BHSY,BHSV
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BHSSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,"BHSY(")
;reorder by date of visit/reverse order
S %=0 F S %=$O(BHSY(%)) Q:%'=+% S BHSV(9999999-$P(BHSY(%),U),$P(BHSY(%),U,5))=""
N PROV,D,V,G
S (D,V)=0,G="" F S D=$O(BHSV(D)) Q:D'=+D!(G) S V=0 F S V=$O(BHSV(D,V)) Q:V'=+V!(G) S PROV=$$PRIMPROV^APCLV(V,"D") I (PROV=24!(PROV=79)!(PROV="08")),'$$DNKA(V),'$$REFR(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Ophthalmologist or Optometrist Visit)"
S (D,V)=0,G="" F S D=$O(BHSV(D)) Q:D'=+D!(G) S V=0 F S V=$O(BHSV(D,V)) Q:V'=+V!(G) S PROV=$$CLINIC^APCLV(V,"C") I (PROV=17!(PROV=18)!(PROV=64)),'$$DNKA(V),'$$REFR(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Optometry or Ophthalmology Clinic)"
S G=$$REFDF^BHSDM3(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),$G(LDFE))
I G]"" Q G
S %="No "_$S($D(LDEE):$$FMTE^XLFDT(LDEE),1:"")
I BHSEX S %=%_" (Diabetic Eye Exam) result: "_$P($$VAL^XBDIQ1(9000010.13,BHSEX,.04),"/",1)
Q %
RECTAL(P,BHSSED) ;EP
I $$AGE^AUPNPAT(P)<41 Q "N/A"
NEW BHSY S %=P_"^LAST EXAM RECTAL",E=$$START1^APCLDF(%,"BHSY(")
I '$D(BHSY) Q "No <never recorded>"
I $P(BHSY(1),U)'<BHSSED S BHSX="Yes "_$$FMTE^XLFDT($P(BHSY(1),U)) Q BHSX
Q "No "_$$FMTE^XLFDT($P(BHSY(1),U))
PAP(P,BHSSED) ;EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
;NEW BHSY S BHSY=$$HYSTER(BHSSDFN,DT) I BHSY]"" Q BHSY
S LPAP=$$LASTPAP^APCHSMU(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 BHSY,%,LPAP,D,J,I,T,V
S LPAP="",%=P_"^LAST LAB PAP SMEAR",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LPAP=$P(BHSY(1),U)
NEW BHSY,BHSLT,%,LPAP S LPAP="",%=P_"^LAST LAB [BGP PAP SMEAR TAX",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LPAP=$P(BHSY(1),U)
;Patch 1001 get last pap smear via loinc code
S BHSLT=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
I BHSLT 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,BHSLT)
....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 BHSY S %=P_"^LAST DX V76.2",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 91.46",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(1),U)
K BHSY NEW % F %=1:1 S T=$T(PAPCPTS+%^BHSMU) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(1),U)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T S X=$$WH^BHSMU2(P,$$DOB^AUPNPAT(P),DT,T,3)
I X]"" D
.Q:LPAP>X
.S LPAP=X
S G=$$REFDF^BHSDM3(P,60,$O(^LAB(60,"B","PAP SMEAR",0)),$G(LPAP))
I G]"" Q $G(LPAP)_"^"_G
Q $G(LPAP)
BREAST(P,BHSSED) ;EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
NEW BHSY,% S %=P_"^LAST EXAM BREAST",E=$$START1^APCLDF(%,"BHSY(")
I '$D(BHSY) Q "No <never recorded>"
I $P(BHSY(1),U)'<BHSSED S BHSX="Yes "_$$FMTE^XLFDT($P(BHSY(1),U)) Q BHSX
Q "No "_$$FMTE^XLFDT($P(BHSY(1),U))
MAMMOG(P) ;EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
NEW LMAM,T S LMAM=""
I $G(^AUTTSITE(1,0)),$P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,10)="353101" S LMAM=$$MAMMOG1(P)
NEW BHSY,%,X,Y,V,G K BHSY
S (X,Y,V)=0 F S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X D
.S V=$P(^AUPNVRAD(X,0),U,3),V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
.I Y=76092,V>LMAM S LMAM=V Q
.I Y=76090,V>LMAM S LMAM=V Q
.I Y=76091,V>LMAM S LMAM=V Q
.I Y=77055,V>LMAM S LMAM=V Q
.I Y=77056,V>LMAM S LMAM=V Q
.I Y=77057,V>LMAM S LMAM=V Q
.I Y=77058,V>LMAM S LMAM=V Q
.I Y=77059,V>LMAM S LMAM=V Q
.I Y="G0202",V>LMAM S LMAM=V Q
.I Y="G0204",V>LMAM S LMAM=V Q
.I Y="G0206",V>LMAM S LMAM=V Q
K BHSY S %=P_"^LAST DX V76.11",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LMAM>$P(BHSY(1),U)
.S LMAM=$P(BHSY(1),U)
K BHSY S %=P_"^LAST DX V76.12",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LMAM>$P(BHSY(1),U)
.S LMAM=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 87.37",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LMAM>$P(BHSY(1),U)
.S LMAM=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 87.36",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LMAM>$P(BHSY(1),U)
.S LMAM=$P(BHSY(1),U)
S T=$O(^ATXAX("B","BGP CPT MAMMOGRAM",0))
S X=$$CPT^APCHSMU2(P,$P(^DPT(P,0),U,3),DT,T,3)
I X D
.Q:LMAM>X
.S LMAM=X
;if wh v3.0 get date for last mammogram
I $$VERSION^XPDUTL("BW")>2 F X="MAMMOGRAM SCREENING","MAMMOGRAM DX UNILATERAL","MAMMOGRAM DX BILATERAL","MAMMOGRAM, UNSPECIFIED" D
.S T=$O(^BWVPDT("B",X,0))
.S V=$$WHAPI^BWVPAT1(P,T)
.I $P(V,U)=0 S $P(V,U)=""
.Q:LMAM>$P(V,U)
.S LMAM=$P(V,U)
;now check wh package directly
F X="MAMMOGRAM SCREENING","MAMMOGRAM DX UNILAT","MAMMOGRAM DX BILAT" D
.S T=$O(^BWPN("B",X,0))
.I T D
..S (G,V)=0 F S V=$O(^BWPCD("C",P,V)) Q:V=""!(G) D
...Q:'$D(^BWPCD(V,0))
...I $P(^BWPCD(V,0),U,4)'=T Q
...S D=$P(^BWPCD(V,0),U,12)
...Q:LMAM>D
...S LMAM=D
.Q
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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_G
S G="" S APCHY=0 F S APCHY=$O(^RAMIS(71,"D",770591,APCHY)) Q:APCHY'=+APCHY!(G]"") D
.S G=$$REFDF^APCHS9B3(P,71,APCHY,$G(LMAM))
I G]"" Q $G(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_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(LMAM)_"^"_G
Q $G(LMAM)
;
MAMMOG1(P) ;for radiology 4.5+ or until qman can handle taxonomies for radiology procedures
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
;
;IHS/ANMC/LJF 8/26/99 new code to look for all mammograms no matter
; how they are spelled in file 71 - for Rad version 4.5+
NEW BHSMAM,CODE,COUNT,IEN,X
S CODE=$O(^DIC(40.7,"C",72,0)) I 'CODE Q "No <never recorded>"
S IEN=0 F S IEN=$O(^RAMIS(71,IEN)) Q:'IEN D
. Q:$G(^RAMIS(71,IEN,"I")) ;inactive
. Q:'$D(^RAMIS(71,IEN,"STOP","B",CODE)) ;no mamm stop code
. S COUNT=$G(COUNT)+1,BHSMAM(COUNT)=$P(^RAMIS(71,IEN,0),U)
;
; -- use data fetcher to find mammogram dates
NEW BHSY,BHSSAV,BHSX,BHSNAM
S (BHSSAV,BHSX)=0 F S BHSX=$O(BHSMAM(BHSX)) Q:'BHSX D
. S %=P_"^LAST RAD "_BHSMAM(BHSX),E=$$START1^APCLDF(%,"BHSY(")
. ; save latest date and procedure name
. I $G(BHSY(1)),$P(BHSY(1),U)>BHSSAV S BHSSAV=$P(BHSY(1),U),BHSNAM=BHSMAM(BHSX)
;
; -- return results
I BHSSAV'=0 Q BHSSAV
;IHS/ANMC/LJF 8/26/99 end of new code
;
Q ""
;
HYSTER(P,EDATE) ;EP
;code set versioning
I '$G(P) Q ""
N C,F,G,S,T
N BHSVDT
;S F=0,S="" F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^ICD0(+^AUPNVPRC(F,0),0),U) D
;changed call to ICDEX for ICD-10s
S F=0,S="" F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S BHSVDT=$P(+^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),"."),C=$P($$ICDOP^ICDEX(+^AUPNVPRC(F,0),BHSVDT,"","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^BHSMU2(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^BHSMU2(P,$P(^DPT(P,0),U,3),EDATE,T,5)
Q ""
BHSDM4 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:24;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,9,12**;March 17, 2006;Build 3
+2 ;===================================================================
+3 ;VA version of IHS components for supplemental summaries
+4 ;Taken from APCHS9B4
+5 ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 05/10/04 6:07 AM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**3,5,6,7,8,10,11,12**;JUN 24, 1997
+7 ;Patch 1001 to bring up to patch 15
+8 ;Patch 2, code set versioning
+9 ;Patch 12, use new API for taxonomies
+10 ;===================================================================
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,BHSS,Y
+4 SET Y="BHSS("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(BHSS(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,TAXARR
+4 ;IHS/MSC/MGH Moved taxonomy lookup out of loop
+5 SET TAXARR=""
+6 SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+7 IF 'T
QUIT ""
+8 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET I=$PIECE(^AUPNPROB(X,0),U)
+10 IF $$ICD^ATXAPI(I,T,9)
Begin DoDot:2
+11 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET D=$ORDER(D(0))
+15 IF D=""
QUIT D
+16 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,BHSSED) ;EP
+1 NEW BHSY,BHSV,%,LDFE
SET LDFE=""
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM"
SET E=$$START1^APCLDF(%,"BHSY(")
+2 IF $DATA(BHSY(1))
SET LDFE=$PIECE(BHSY(1),U)
+3 IF $DATA(BHSY(1))
IF $PIECE(BHSY(1),U)'<BHSSED
SET BHSX="Yes "_$$FMTE^XLFDT($PIECE(BHSY(1),U))_" (Diabetic Foot Exam, Complete)"
QUIT BHSX
+4 ;now check any clinic 65 or prov 33/25
+5 KILL BHSY,BHSV
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BHSSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"BHSY(")
+7 ;reorder by date of visit/reverse order
+8 SET %=0
FOR
SET %=$ORDER(BHSY(%))
IF %'=+%
QUIT
SET BHSV(9999999-$PIECE(BHSY(%),U),$PIECE(BHSY(%),U,5))=""
+9 NEW PROV,D,V,G
SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(BHSV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(BHSV(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(BHSV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(BHSV(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^BHSDM3(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,BHSSED) ;EP
+1 NEW BHSY,LDEE,%,BHSEX
SET BHSEX=0
SET LDEE=""
SET %=P_"^LAST EXAM DIABETIC EYE EXAM"
SET E=$$START1^APCLDF(%,"BHSY(")
+2 IF $DATA(BHSY(1))
SET LDEE=$PIECE(BHSY(1),U)
SET BHSEX=+$PIECE(BHSY(1),U,4)
+3 IF $PIECE($GET(BHSY(1)),U)'<BHSSED
SET BHSX="Yes "_$$FMTE^XLFDT($PIECE(BHSY(1),U))_" (Diabetic Eye Exam)"
QUIT BHSX
+4 KILL BHSY
SET BHSCPT=""
+5 NEW T,C,BHSCPT,BHSCPT1
+6 ;PATCH UPDATES
+7 FOR C=992250,92012,92014,92004,92002
SET T=$ORDER(^ICPT("B",C,0))
Begin DoDot:1
+8 IF T
SET BHSY=$ORDER(^AUPNVCPT("AA",P,T,0))
IF BHSY
Begin DoDot:2
+9 SET BHSY=9999999-BHSY
+10 IF LDEE<BHSY
SET LDEE=BHSY
SET BHSEX=0
SET BHSCPT=T
SET BHSCPT1=C
End DoDot:2
End DoDot:1
+11 ;I LDEE,LDEE'<BHSSED Q "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_BHSCPT1_"-"_$E($P(^ICPT(BHSCPT,0),U,2),1,28)_")"
+12 ;code set versioning cmi/anch/maw 8/2
IF LDEE
IF LDEE'<BHSSED
QUIT "Yes "_$$FMTE^XLFDT(LDEE)_" (CPT "_BHSCPT1_"-"_$EXTRACT($PIECE($$CPT^ICPTCOD(BHSCPT,LDEE),U,3),1,28)_")"
+13 ;END PATCH UPDATES
+14 ;now check any clinic 17 or 18
+15 KILL BHSY,BHSV
+16 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BHSSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,"BHSY(")
+17 ;reorder by date of visit/reverse order
+18 SET %=0
FOR
SET %=$ORDER(BHSY(%))
IF %'=+%
QUIT
SET BHSV(9999999-$PIECE(BHSY(%),U),$PIECE(BHSY(%),U,5))=""
+19 NEW PROV,D,V,G
+20 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(BHSV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(BHSV(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)
SET G=9999999-D
+21 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Ophthalmologist or Optometrist Visit)"
+22 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(BHSV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(BHSV(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)
SET G=9999999-D
+23 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Optometry or Ophthalmology Clinic)"
+24 SET G=$$REFDF^BHSDM3(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),$GET(LDFE))
+25 IF G]""
QUIT G
+26 SET %="No "_$SELECT($DATA(LDEE):$$FMTE^XLFDT(LDEE),1:"")
+27 IF BHSEX
SET %=%_" (Diabetic Eye Exam) result: "_$PIECE($$VAL^XBDIQ1(9000010.13,BHSEX,.04),"/",1)
+28 QUIT %
RECTAL(P,BHSSED) ;EP
+1 IF $$AGE^AUPNPAT(P)<41
QUIT "N/A"
+2 NEW BHSY
SET %=P_"^LAST EXAM RECTAL"
SET E=$$START1^APCLDF(%,"BHSY(")
+3 IF '$DATA(BHSY)
QUIT "No <never recorded>"
+4 IF $PIECE(BHSY(1),U)'<BHSSED
SET BHSX="Yes "_$$FMTE^XLFDT($PIECE(BHSY(1),U))
QUIT BHSX
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(BHSY(1),U))
PAP(P,BHSSED) ;EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 ;NEW BHSY S BHSY=$$HYSTER(BHSSDFN,DT) I BHSY]"" Q BHSY
+3 SET LPAP=$$LASTPAP^APCHSMU(P)
+4 SET G=$$REFDF^APCHS9B3(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$GET(LPAP))
+5 IF G]""
QUIT $GET(LPAP)_"^"_G
+6 QUIT $GET(LPAP)
OLDPAP ;
+1 NEW BHSY,%,LPAP,D,J,I,T,V
+2 SET LPAP=""
SET %=P_"^LAST LAB PAP SMEAR"
SET E=$$START1^APCLDF(%,"BHSY(")
+3 IF $DATA(BHSY(1))
SET LPAP=$PIECE(BHSY(1),U)
+4 NEW BHSY,BHSLT,%,LPAP
SET LPAP=""
SET %=P_"^LAST LAB [BGP PAP SMEAR TAX"
SET E=$$START1^APCLDF(%,"BHSY(")
+5 IF $DATA(BHSY(1))
SET LPAP=$PIECE(BHSY(1),U)
+6 ;Patch 1001 get last pap smear via loinc code
+7 SET BHSLT=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+8 IF BHSLT
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,BHSLT)
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 BHSY
SET %=P_"^LAST DX V76.2"
SET E=$$START1^APCLDF(%,"BHSY(")
+23 IF $DATA(BHSY(1))
Begin DoDot:1
+24 IF LPAP>$PIECE(BHSY(1),U)
QUIT
+25 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+26 KILL BHSY
SET %=P_"^LAST PROCEDURE 91.46"
SET E=$$START1^APCLDF(%,"BHSY(")
+27 IF $DATA(BHSY(1))
Begin DoDot:1
+28 IF LPAP>$PIECE(BHSY(1),U)
QUIT
+29 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+30 KILL BHSY
NEW %
FOR %=1:1
SET T=$TEXT(PAPCPTS+%^BHSMU)
IF $PIECE(T,";;",2)=""
QUIT
SET T=$PIECE(T,";;",2)
SET T=$ORDER(^ICPT("B",T,0))
IF T
SET BHSY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
IF BHSY(1)
SET BHSY(1)=9999999-BHSY(1)
Begin DoDot:1
+31 IF LPAP>$PIECE(BHSY(1),U)
QUIT
+32 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+33 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+34 IF T
SET X=$$WH^BHSMU2(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^BHSDM3(P,60,$ORDER(^LAB(60,"B","PAP SMEAR",0)),$GET(LPAP))
+39 IF G]""
QUIT $GET(LPAP)_"^"_G
+40 QUIT $GET(LPAP)
BREAST(P,BHSSED) ;EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 NEW BHSY,%
SET %=P_"^LAST EXAM BREAST"
SET E=$$START1^APCLDF(%,"BHSY(")
+3 IF '$DATA(BHSY)
QUIT "No <never recorded>"
+4 IF $PIECE(BHSY(1),U)'<BHSSED
SET BHSX="Yes "_$$FMTE^XLFDT($PIECE(BHSY(1),U))
QUIT BHSX
+5 QUIT "No "_$$FMTE^XLFDT($PIECE(BHSY(1),U))
MAMMOG(P) ;EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 NEW LMAM,T
SET LMAM=""
+3 IF $GET(^AUTTSITE(1,0))
IF $PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,10)="353101"
SET LMAM=$$MAMMOG1(P)
+4 NEW BHSY,%,X,Y,V,G
KILL BHSY
+5 SET (X,Y,V)=0
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+7 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+8 IF Y=76092
IF V>LMAM
SET LMAM=V
QUIT
+9 IF Y=76090
IF V>LMAM
SET LMAM=V
QUIT
+10 IF Y=76091
IF V>LMAM
SET LMAM=V
QUIT
+11 IF Y=77055
IF V>LMAM
SET LMAM=V
QUIT
+12 IF Y=77056
IF V>LMAM
SET LMAM=V
QUIT
+13 IF Y=77057
IF V>LMAM
SET LMAM=V
QUIT
+14 IF Y=77058
IF V>LMAM
SET LMAM=V
QUIT
+15 IF Y=77059
IF V>LMAM
SET LMAM=V
QUIT
+16 IF Y="G0202"
IF V>LMAM
SET LMAM=V
QUIT
+17 IF Y="G0204"
IF V>LMAM
SET LMAM=V
QUIT
+18 IF Y="G0206"
IF V>LMAM
SET LMAM=V
QUIT
End DoDot:1
+19 KILL BHSY
SET %=P_"^LAST DX V76.11"
SET E=$$START1^APCLDF(%,"BHSY(")
+20 IF $DATA(BHSY(1))
Begin DoDot:1
+21 IF LMAM>$PIECE(BHSY(1),U)
QUIT
+22 SET LMAM=$PIECE(BHSY(1),U)
End DoDot:1
+23 KILL BHSY
SET %=P_"^LAST DX V76.12"
SET E=$$START1^APCLDF(%,"BHSY(")
+24 IF $DATA(BHSY(1))
Begin DoDot:1
+25 IF LMAM>$PIECE(BHSY(1),U)
QUIT
+26 SET LMAM=$PIECE(BHSY(1),U)
End DoDot:1
+27 KILL BHSY
SET %=P_"^LAST PROCEDURE 87.37"
SET E=$$START1^APCLDF(%,"BHSY(")
+28 IF $DATA(BHSY(1))
Begin DoDot:1
+29 IF LMAM>$PIECE(BHSY(1),U)
QUIT
+30 SET LMAM=$PIECE(BHSY(1),U)
End DoDot:1
+31 KILL BHSY
SET %=P_"^LAST PROCEDURE 87.36"
SET E=$$START1^APCLDF(%,"BHSY(")
+32 IF $DATA(BHSY(1))
Begin DoDot:1
+33 IF LMAM>$PIECE(BHSY(1),U)
QUIT
+34 SET LMAM=$PIECE(BHSY(1),U)
End DoDot:1
+35 SET T=$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0))
+36 SET X=$$CPT^APCHSMU2(P,$PIECE(^DPT(P,0),U,3),DT,T,3)
+37 IF X
Begin DoDot:1
+38 IF LMAM>X
QUIT
+39 SET LMAM=X
End DoDot:1
+40 ;if wh v3.0 get date for last mammogram
+41 IF $$VERSION^XPDUTL("BW")>2
FOR X="MAMMOGRAM SCREENING","MAMMOGRAM DX UNILATERAL","MAMMOGRAM DX BILATERAL","MAMMOGRAM, UNSPECIFIED"
Begin DoDot:1
+42 SET T=$ORDER(^BWVPDT("B",X,0))
+43 SET V=$$WHAPI^BWVPAT1(P,T)
+44 IF $PIECE(V,U)=0
SET $PIECE(V,U)=""
+45 IF LMAM>$PIECE(V,U)
QUIT
+46 SET LMAM=$PIECE(V,U)
End DoDot:1
+47 ;now check wh package directly
+48 FOR X="MAMMOGRAM SCREENING","MAMMOGRAM DX UNILAT","MAMMOGRAM DX BILAT"
Begin DoDot:1
+49 SET T=$ORDER(^BWPN("B",X,0))
+50 IF T
Begin DoDot:2
+51 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""!(G)
QUIT
Begin DoDot:3
+52 IF '$DATA(^BWPCD(V,0))
QUIT
+53 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+54 SET D=$PIECE(^BWPCD(V,0),U,12)
+55 IF LMAM>D
QUIT
+56 SET LMAM=D
End DoDot:3
End DoDot:2
+57 QUIT
End DoDot:1
+58 SET G=""
+59 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76090,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+60 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+61 IF G]""
QUIT $GET(LMAM)_"^"_G
+62 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76091,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+63 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+64 IF G]""
QUIT $GET(LMAM)_"^"_G
+65 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",76092,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+66 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+67 IF G]""
QUIT $GET(LMAM)_"^"_G
+68 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77055,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+69 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+70 IF G]""
QUIT $GET(LMAM)_"^"_G
+71 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77056,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+72 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+73 IF G]""
QUIT $GET(LMAM)_"^"_G
+74 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77057,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+75 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+76 IF G]""
QUIT $GET(LMAM)_"^"_G
+77 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",77058,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+78 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+79 IF G]""
QUIT $GET(LMAM)_"^"_G
+80 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D",770591,APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+81 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+82 IF G]""
QUIT $GET(LMAM)_"^"_G
+83 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0202",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+84 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+85 IF G]""
QUIT $GET(LMAM)_"^"_G
+86 KILL APCHY
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0204",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+87 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+88 IF G]""
QUIT $GET(LMAM)_"^"_G
+89 SET G=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^RAMIS(71,"D","G0206",APCHY))
IF APCHY'=+APCHY!(G]"")
QUIT
Begin DoDot:1
+90 SET G=$$REFDF^APCHS9B3(P,71,APCHY,$GET(LMAM))
End DoDot:1
+91 IF G]""
QUIT $GET(LMAM)_"^"_G
+92 QUIT $GET(LMAM)
+93 ;
MAMMOG1(P) ;for radiology 4.5+ or until qman can handle taxonomies for radiology procedures
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 ;
+3 ;IHS/ANMC/LJF 8/26/99 new code to look for all mammograms no matter
+4 ; how they are spelled in file 71 - for Rad version 4.5+
+5 NEW BHSMAM,CODE,COUNT,IEN,X
+6 SET CODE=$ORDER(^DIC(40.7,"C",72,0))
IF 'CODE
QUIT "No <never recorded>"
+7 SET IEN=0
FOR
SET IEN=$ORDER(^RAMIS(71,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+8 ;inactive
IF $GET(^RAMIS(71,IEN,"I"))
QUIT
+9 ;no mamm stop code
IF '$DATA(^RAMIS(71,IEN,"STOP","B",CODE))
QUIT
+10 SET COUNT=$GET(COUNT)+1
SET BHSMAM(COUNT)=$PIECE(^RAMIS(71,IEN,0),U)
End DoDot:1
+11 ;
+12 ; -- use data fetcher to find mammogram dates
+13 NEW BHSY,BHSSAV,BHSX,BHSNAM
+14 SET (BHSSAV,BHSX)=0
FOR
SET BHSX=$ORDER(BHSMAM(BHSX))
IF 'BHSX
QUIT
Begin DoDot:1
+15 SET %=P_"^LAST RAD "_BHSMAM(BHSX)
SET E=$$START1^APCLDF(%,"BHSY(")
+16 ; save latest date and procedure name
+17 IF $GET(BHSY(1))
IF $PIECE(BHSY(1),U)>BHSSAV
SET BHSSAV=$PIECE(BHSY(1),U)
SET BHSNAM=BHSMAM(BHSX)
End DoDot:1
+18 ;
+19 ; -- return results
+20 IF BHSSAV'=0
QUIT BHSSAV
+21 ;IHS/ANMC/LJF 8/26/99 end of new code
+22 ;
+23 QUIT ""
+24 ;
HYSTER(P,EDATE) ;EP
+1 ;code set versioning
+2 IF '$GET(P)
QUIT ""
+3 NEW C,F,G,S,T
+4 NEW BHSVDT
+5 ;S F=0,S="" F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F!(S) S C=$P(^ICD0(+^AUPNVPRC(F,0),0),U) D
+6 ;changed call to ICDEX for ICD-10s
+7 SET F=0
SET S=""
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F!(S)
QUIT
SET BHSVDT=$PIECE(+^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),".")
SET C=$PIECE($$ICDOP^ICDEX(+^AUPNVPRC(F,0),BHSVDT,"","I"),U,2)
Begin DoDot:1
+8 ;cmi/anch/maw 8/27/2007 end of mods
+9 SET G=0
IF (C=68.4)!(C=68.5)!(C=68.6)!(C=68.7)!(C=68.9)
SET G=C
+10 IF G=0
QUIT
+11 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+12 ;I D>EDATE Q
+13 SET S=1
End DoDot:1
+14 IF S]""
QUIT "Pt had Hysterectomy on "_$$FMTE^XLFDT(D,2)_" procedure: "_G
+15 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+16 IF T
Begin DoDot:1
+17 SET X=$$WH^BHSMU2(P,$$DOB^AUPNPAT(P),EDATE,T,3)
End DoDot:1
IF X]""
QUIT "Hysterectomy documented in Women's Health: "_$$FMTE^XLFDT(X,2)
+18 SET T=$ORDER(^ATXAX("B","BGP HYSTERECTOMY CPTS",0))
+19 IF T
Begin DoDot:1
+20 SET X=$$CPT^BHSMU2(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)
+21 QUIT ""
