APCHPRE1 ; IHS/CMI/GRL - PATIENT HEALTH SUMMARY ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
EP(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
K ^TMP("APCHPHS",$J,"PHS")
S ^TMP("APCHPHS",$J,"PHS",0)=0
D SETARRAY
Q
;
SETARRAY ;set up array containing dm care summary
;CHECK TO SEE IF START1^APCLDF EXISTS
S X="APCLDF" X ^%ZOSF("TEST") I '$T Q
;S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$P(^DIC(4,DUZ(2),0),U) D S(X,2)
S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,2)
S X=$$VAL^XBDIQ1(2,APCHSDFN,.111),$E(X,50)=$$VAL^XBDIQ1(9000001,APCHSDFN,.14) D S(X)
S X=$$VAL^XBDIQ1(2,APCHSDFN,.114)_$S($$VAL^XBDIQ1(2,APCHSDFN,.114)]"":", ",1:" ")_$$VAL^XBDIQ1(2,APCHSDFN,.115)_" "_$$VAL^XBDIQ1(2,APCHSDFN,.116),Y=$P(^AUTTLOC(DUZ(2),0),U,11),$E(X,50)=Y D S(X)
S X="Hello "_$S($$SEX^AUPNPAT(APCHSDFN)="M":"Mr. ",1:"Ms. ")_$E($P($P(^DPT(APCHSDFN,0),U),","))_$$LOW^XLFSTR($E($P($P(^DPT(APCHSDFN,0),U),","),2,99))_"," D S(X,1)
S X="Thanks for choosing "_$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
S X="This sheet is a new way for you and your doctor to look at your health." D S(X)
S X="DISEASE PREVENTION CARE" D S(X,1)
GLUCOSE ;
I $$AGE^AUPNPAT(APCHSDFN)>10 D
.Q:$$DMDX(APCHSDFN)=""
.S X="",$E(X,5)="Since you have diabetes - this helps see how well your" D S(X,1)
.S X="",$E(X,5)="treatment is working." D S(X)
.S T=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0)) I $G(T)]"" S APCHLFGV=$$LAB(APCHSDFN,T),APCHLFGD=$P($G(APCHLFGV),"|||",2),APCHLFGV=$P($G(APCHLFGV),"|||") D
..S X="",$E(X,5)="Last Fasting Blood Sugar: "_$S($G(APCHLFGV)]"":APCHLFGV_" ("_APCHLFGD_")",1:"No Fasting Blood Sugar on File") D S(X)
..;get last FBS date. If > 2 yr write "You are due to have a blood sugar level checked"
..I APCHLFGD]"" S X=APCHLFGD D ^%DT S APCHLFGD=Y S X1=DT,X2=APCHLFGD I $$FMDIFF^XLFDT(X1,X2)>365 S X="",$E(X,5)="Since it's been over 1 year - time to do this test again." D S(X)
.I $G(APCHLFGV)']"" S T=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0)) I $G(T)]"" S APCHLGLV=$$LAB(APCHSDFN,T),APCHLGLD=$P($G(APCHLGLV),"|||",2),APCHLGLV=$P($G(APCHLGLV),"|||") D
.I $G(APCHLGLV)]"" S X="",$E(X,5)="Last Blood Sugar: "_APCHLGLV_" ("_APCHLGLD_")" D S(X)
.Q
;
I $$DMDX(APCHSDFN)="" D
.Q:$$AGE^AUPNPAT(APCHSDFN)<18
.S T=$O(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0)) I $G(T)]"" S APCHLGLV=$$LAB(APCHSDFN,T),APCHLGLD=$P($G(APCHLGLV),"|||",2),APCHLGLV=$P($G(APCHLGLV),"|||") D
..I $G(APCHLGLV)']"" S X="",$E(X,5)="No Blood Sugar on file - should be done now." D S(X) Q
..I APCHLGLV]"" S X="",$E(X,5)="Last Blood Sugar: "_APCHLGLV_" ("_APCHLGLD_")" D S(X)
..I APCHLGLD]"" S X=APCHLGLD D ^%DT S APCHLGLD=Y S X1=DT,X2=APCHLGLD I $$FMDIFF^XLFDT(X1,X2)>730 S X="",$E(X,5)="Since it's been over 2 years - time to do this test again." D S(X)
.Q
;
IMMUN ;Immunizaitons
S X="IMMUNIZATIONS(SHOTS) Getting shots protects you from some diseases and" D S(X,1)
S X="illnesses." D S(X)
;
D IMMFORC^BIRPC(.APCHIMM,APCHSDFN)
I $E($G(APCHIMM),1,2)="No" S X="",$E(X,5)="Good news! Your immunizations are up to date" D S(X)
I $E($G(APCHIMM),1,2)=" " F APCHIMMN=1:1 S APCHIMMT=$P($P(APCHIMM,U,APCHIMMN),"|") Q:$G(APCHIMMT)']"" D
.I $E(APCHIMMT,1,2)=" " S APCHIMMT=$E(APCHIMMT,3,99)
.I $G(APCHIMMT)]"" S APCHI(APCHIMMN)=APCHIMMT
.Q
I $G(APCHIMM)]"",+APCHIMM S X="",$E(X,5)="Immunizations are due." D S(X)
I $D(APCHI) S APCHICTR=0 D
.S X="",$E(X,5)="Immunizations due:" D S(X)
.F S APCHICTR=$O(APCHI(APCHICTR)) Q:APCHICTR'=+APCHICTR D
..S APCHIMDU=$P(APCHI(APCHICTR),U),X="",$E(X,5)=APCHIMDU D S(X)
..Q
;
CRECTAL ;Colorectal screening
I $$AGE^AUPNPAT(APCHSDFN)>50 D
.Q:$$CRC(APCHSDFN,DT)=1 ;has CRC dx
.S X="COLORECTAL SCREENING This test may show cancer, even when you feel ok." D S(X,1)
.S APCHLFOB=$$LASTFOBT^APCLAPI3(APCHSDFN),APCHLBE=$$LASTBE^APCLAPI4(APCHSDFN),APCHLCOL=$$LASTCOLO^APCLAPI(APCHSDFN),APCHLSIG=$$LASTFSIG^APCLAPI(APCHSDFN)
.S APCHLDRE=$$LASTRECT^APCLAPI2(APCHSDFN)
.S APCHSCRN=""
.I $G(APCHLDRE)]"" S APCHSCRN=APCHLDRE I $$FMDIFF^XLFDT(DT,APCHLDRE)<720 S APCHCOLO=1
.I $G(APCHLFOB)]"",APCHLFOB>APCHSCRN S APCHSCRN=APCHLFOB I $$FMDIFF^XLFDT(DT,APCHLFOB)<720 S APCHCOLO=1
.I $G(APCHLCOL)]"",APCHLCOL>APCHSCRN S APCHSCRN=APCHLCOL I $$FMDIFF^XLFDT(DT,APCHLCOL)<3650 S APCHCOLO=1
.I $G(APCHLBE)]"",APCHLBE>APCHSCRN S APCHSCRN=APCHLBE I $$FMDIFF^XLFDT(DT,APCHLBE)<1825 S APCHCOLO=1
.I $G(APCHLSIG)]"",APCHLSIG>APCHSCRN S APCHSCRN=APCHLSIG I $$FMDIFF^XLFDT(DT,APCHLSIG)<1825 S APCHCOLO=1
.I $G(APCHSCRN)]"" S X="",$E(X,5)="Your last colorectal screening was performed on "_$$FMTE^XLFDT(APCHSCRN) D S(X)
.I $G(APCHCOLO)'=1 S X="",$E(X,5)="Your colorectal screening is due now" D S(X)
;
WOMENS ;Womens health issues
;first get cervical and breast needs from BW package
S APCHPNV=$$VAL^XBDIQ1(9002086,APCHSDFN,.11) I $G(APCHPNV)["PAP" S APCHPND=$$VALI^XBDIQ1(9002086,APCHSDFN,.12)
S APCHMNV=$$VAL^XBDIQ1(9002086,APCHSDFN,.18) I $G(APCHMNV)["Mammo"!($G(APCHMNV)["MAM") S APCHMND=$$VALI^XBDIQ1(9002086,APCHSDFN,.19)
;now check last PAP and mammogram
I $$SEX^AUPNPAT(APCHSDFN)="F",$$AGE^AUPNPAT(APCHSDFN)>18,$$AGE^AUPNPAT(APCHSDFN)<66 S X="MAMMOGRAM and PAP SCREEN These may show cancer even when you feel ok." D S(X,1) D
.S APCHSPAP=$$LASTPAP^APCLAPI1(APCHSDFN) I APCHSPAP]"" S X="",$E(X,5)="Your last PAP was performed on "_$$FMTE^XLFDT($$LASTPAP^APCHSMU(APCHSDFN)) D S(X,1)
.I $G(APCHPNV)']"",APCHSPAP]"" S X1=DT,X2=APCHSPAP I $$FMDIFF^XLFDT(X1,X2)>1095 S X="",$E(X,5)="Your PAP is due now" D S(X)
.I '$G(APCHPND),APCHSPAP="" S X="",$E(X,5)="Your PAP is due now" D S(X,1)
.I $G(APCHPND)]"",APCHPND<DT,APCHPND>APCHSPAP S X="",$E(X,5)="Your PAP is due now" D S(X)
.I $$AGE^AUPNPAT(APCHSDFN)>49 D
..S APCHMAM=$$LASTMAM^APCLAPI1(APCHSDFN) I APCHSMAM]"" S X="",$E(X,5)="Your last mammogram was performed on "_$$FMTE^XLFDT(APCHSMAM) D S(X)
..I $G(APCHMNV)']"",APCHSMAM]"" S X1=DT,X2=APCHSMAM I $$FMDIFF^XLFDT(X1,X2)>365 S X="",$E(X,5)="Your mammogram is due now" D S(X)
..I APCHSMAM="" S X="",$E(X,5)="Your mammogram is due now" D S(X)
..I $G(APCHMND)]"",APCHMND<DT,APCHMND>APCHSMAM S X="",$E(X,5)="Your mammogram is due now" D S(X)
..I $G(APCHMND)]"",APCHMND<DT,APCHMND=APCHSMAM S X="",$E(X,5)="Your mammogram is due now" D S(X) ;WH MAM need date not updated
;
I $$SEX^AUPNPAT(APCHSDFN)="F",$$AGE^AUPNPAT(APCHSDFN)>40,$$AGE^AUPNPAT(APCHSDFN)<50,APCHSMAM="" S X="",$E(X,5)="Your mammogram is due at age 50" D S(X)
;
HEARING ;
I $$AGE^AUPNPAT(APCHSDFN)>64 D
.S X="HEARING TEST This may show loss of good hearing - and if a hearing aid" D S(X,1)
.S X="would help." D S(X)
.;get hearing test history
.I $$LASTHEAR^APCLAPI3(APCHSDFN)]"" S X="",$E(X,5)="Your last hearing test was performed on "_$$FMTE^XLFDT($$LASTHEAR^APCLAPI3(APCHSDFN)) D S(X,1)
.I $$LASTHEAR^APCLAPI3(APCHSDFN)="" S X="",$E(X,5)="Your hearing test is due now" D S(X,1)
.Q
;
S X="",$E(X,5)="Ask your provider about ways you can stay healthy." D S(X,2)
;
HABITS ;
S X="HEALTH HABITS" D S(X,1)
S X="Please answer the questions. Mark the box next to your answer." D S(X,1)
S X="FEELING SAD" D S(X,1)
S X="During the past month, have you felt down, depressed, or hopeless?" D S(X)
S X="" S $E(X,5)="[ ] Yes",$E(X,15)="[ ] No" D S(X)
S X="During the past month, have you felt little interest or pleasure in" D S(X)
S X="doing things you used to like to do?" D S(X)
S X="" S $E(X,5)="[ ] Yes",$E(X,15)="[ ] No" D S(X)
S X="ALCOHOL USE" D S(X,1)
S X="In the past year, how often do you drink? A drink is one bottle of beer," D S(X)
S X="one glass of wine, one wine cooler, one cocktail or one shot of hard liquor" D S(X)
S X="(like whiskey, scotch, gin or vodka)." D S(X)
S X="",$E(X,5)="[ ] Never",$E(X,25)="[ ] Monthly or less",$E(X,45)="[ ] 2-4 times/month" D S(X)
S X="",$E(X,5)="[ ] 2-3 times/week",$E(X,25)="[ ] 4-5 times/week",$E(X,45)="[ ] 6+ days/week" D S(X)
S X="When you drink, about how many drinks do you have?" D S(X,1)
S X="",$E(X,5)="[ ] 0 drinks",$E(X,25)="[ ] 1-2 drinks",$E(X,45)="[ ] 3-4 drinks" D S(X)
S X="",$E(X,5)="[ ] 5-6 drinks",$E(X,25)="[ ] 7-9 drinks",$E(X,45)="[ ] 10+ drinks" D S(X)
S X="How many times in the past year did you have "_$S($$SEX^AUPNPAT(APCHSDFN)="M":"6 or more drinks in one day?",1:"4 or more drinks in one day?") D S(X,1)
S X="",$E(X,5)="[ ] Never",$E(X,25)="[ ] Monthly",$E(X,45)="[ ] Less than monthly" D S(X)
S X="",$E(X,5)="[ ] Weekly",$E(X,25)="[ ] Daily or almost daily" D S(X)
S X="TOBACCO" D S(X,1)
S X="Mark the answers which best describe your smoking history." D S(X)
S X="",$E(X,5)="[ ] Never used tobacco(lifetime non-tobacco user)" D S(X)
S X="",$E(X,5)="[ ] Current Smoker (cigarettes or cigars)" D S(X)
S X="",$E(X,10)="[ ] Trying to quit smoking" D S(X)
S X="",$E(X,5)="[ ] Current chewing (smokeless) tobacco user" D S(X)
S X="",$E(X,10)="[ ] Trying to quit chewing" D S(X)
S X="",$E(X,5)="[ ] Used to smoke - but quit" D S(X)
S X="",$E(X,5)="[ ] Used to chew - but quit" D S(X)
S X="",$E(X,5)="[ ] Only use for religious or cultural reasons" D S(X)
S X="Does anyone smoke at your home? [ ] Yes [ ] No" D S(X)
Q:$$SEX^AUPNPAT(APCHSDFN)="M"
Q:$$AGE^AUPNPAT(APCHSDFN)<16
S X="FAMILY PLANNING" D S(X,1)
S X="Are you planning to have a baby this week, this month, this year? [ ] Yes [ ] No" D S(X)
S X="Do you or your partner use a form of birth control? [ ] Yes [ ] No" D S(X)
S X="",$E(X,5)="[ ] Condom [ ] Diaphragm [ ] Birth Control Pills [ ] Sterilization" D S(X)
S X="",$E(X,5)="[ ] Rhythm Method [ ] A shot [ ] Other [ ] I do not use birth control" D S(X)
Q
;
;
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHPHS",$J,"PHS",0),U)+1,$P(^TMP("APCHPHS",$J,"PHS",0),U)=%
S ^TMP("APCHPHS",$J,"PHS",%)=X
Q
DMDX(P) ;
;check problem list OR must have 3 diagnoses
N T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",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^ATXAPI(Y,T,9) S I=1
I I Q "Yes"
NEW APCHX
S APCHX=""
S X=P_"^LAST 3 DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,"APCHX(") G:E DMX I $D(APCHX(3)) S APCHX="Yes"
I '$D(APCHX)="" S APCHX="No"
DMX ;
Q APCHX
;
LAB(P,T,LT) ;EP
I '$G(LT) S LT=""
NEW D,V,G,X,J S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=Y
...Q
..Q
.Q
I 'G S R=$$REF(P,T) Q "||||||"_R
Q $P(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_$$REF(P,T,$P($P(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_G
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(D) S D=""
N APCHREF,APCHT,V S APCHT=0 F S APCHT=$O(^ATXLAB(T,21,"B",APCHT)) Q:APCHT'=+APCHT D
.S V=$$REF1(P,60,APCHT,D) I V]"" S APCHREF(9999999-$P(V,U,3))=V
I $D(APCHREF) S %=0,%=$O(APCHREF(%)) I % S V=APCHREF(%) Q V
Q ""
REF1(P,F,I,D,T) ; ;
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(D)="" S D=""
I $G(T)="" S T="E"
NEW X,N S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q "" ;none of this item was refused
S N=$O(^AUPNPREF("AA",P,F,I,X,0))
NEW Y S Y=9999999-X
I D]"",Y>D Q $S(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
I T="I" Q Y ;quit on internal form of date
Q $$TYPEREF(N)_"-"_$$DATE(Y)
;
TYPEREF(N) ;
NEW % S %=$P(^AUPNPREF(N,0),U,7)
I %="R"!(%="") Q "Refused"
I %="N" Q "Not Med Ind"
I %="F" Q "No Resp to F/U"
Q ""
;
CRC(P,EDATE) ;
K APCHG
S Y="APCHG("
S X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(APCHG(1)) Q 1 ;has dx
Q 0
;
APCHPRE1 ; IHS/CMI/GRL - PATIENT HEALTH SUMMARY ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
EP(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
+1 KILL ^TMP("APCHPHS",$JOB,"PHS")
+2 SET ^TMP("APCHPHS",$JOB,"PHS",0)=0
+3 DO SETARRAY
+4 QUIT
+5 ;
SETARRAY ;set up array containing dm care summary
+1 ;CHECK TO SEE IF START1^APCLDF EXISTS
+2 SET X="APCLDF"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+3 ;S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$P(^DIC(4,DUZ(2),0),U) D S(X,2)
+4 SET X=$PIECE($PIECE(^DPT(APCHSDFN,0),U),",",2)_" "_$PIECE($PIECE(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2))
SET $EXTRACT(X,50)=$SELECT($PIECE(^APCCCTRL(DUZ(2),0),U,13)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,13),1:$PIECE(^DIC(4,DUZ(2),0),U))
DO S(X,2)
+5 SET X=$$VAL^XBDIQ1(2,APCHSDFN,.111)
SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9000001,APCHSDFN,.14)
DO S(X)
+6 SET X=$$VAL^XBDIQ1(2,APCHSDFN,.114)_$SELECT($$VAL^XBDIQ1(2,APCHSDFN,.114)]"":", ",1:" ")_$$VAL^XBDIQ1(2,APCHSDFN,.115)_" "_$$VAL^XBDIQ1(2,APCHSDFN,.116)
SET Y=$PIECE(^AUTTLOC(DUZ(2),0),U,11)
SET $EXTRACT(X,50)=Y
DO S(X)
+7 SET X="Hello "_$SELECT($$SEX^AUPNPAT(APCHSDFN)="M":"Mr. ",1:"Ms. ")_$EXTRACT($PIECE($PIECE(^DPT(APCHSDFN,0),U),","))_$$LOW^XLFSTR($EXTRACT($PIECE($PIECE(^DPT(APCHSDFN,0),U),","),2,99))_","
DO S(X,1)
+8 SET X="Thanks for choosing "_$SELECT($PIECE(^APCCCTRL(DUZ(2),0),U,13)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,13),1:$PIECE(^DIC(4,DUZ(2),0),U))
DO S(X,1)
+9 SET X="This sheet is a new way for you and your doctor to look at your health."
DO S(X)
+10 SET X="DISEASE PREVENTION CARE"
DO S(X,1)
GLUCOSE ;
+1 IF $$AGE^AUPNPAT(APCHSDFN)>10
Begin DoDot:1
+2 IF $$DMDX(APCHSDFN)=""
QUIT
+3 SET X=""
SET $EXTRACT(X,5)="Since you have diabetes - this helps see how well your"
DO S(X,1)
+4 SET X=""
SET $EXTRACT(X,5)="treatment is working."
DO S(X)
+5 SET T=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
IF $GET(T)]""
SET APCHLFGV=$$LAB(APCHSDFN,T)
SET APCHLFGD=$PIECE($GET(APCHLFGV),"|||",2)
SET APCHLFGV=$PIECE($GET(APCHLFGV),"|||")
Begin DoDot:2
+6 SET X=""
SET $EXTRACT(X,5)="Last Fasting Blood Sugar: "_$SELECT($GET(APCHLFGV)]"":APCHLFGV_" ("_APCHLFGD_")",1:"No Fasting Blood Sugar on File")
DO S(X)
+7 ;get last FBS date. If > 2 yr write "You are due to have a blood sugar level checked"
+8 IF APCHLFGD]""
SET X=APCHLFGD
DO ^%DT
SET APCHLFGD=Y
SET X1=DT
SET X2=APCHLFGD
IF $$FMDIFF^XLFDT(X1,X2)>365
SET X=""
SET $EXTRACT(X,5)="Since it's been over 1 year - time to do this test again."
DO S(X)
End DoDot:2
+9 IF $GET(APCHLFGV)']""
SET T=$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
IF $GET(T)]""
SET APCHLGLV=$$LAB(APCHSDFN,T)
SET APCHLGLD=$PIECE($GET(APCHLGLV),"|||",2)
SET APCHLGLV=$PIECE($GET(APCHLGLV),"|||")
Begin DoDot:2
End DoDot:2
+10 IF $GET(APCHLGLV)]""
SET X=""
SET $EXTRACT(X,5)="Last Blood Sugar: "_APCHLGLV_" ("_APCHLGLD_")"
DO S(X)
+11 QUIT
End DoDot:1
+12 ;
+13 IF $$DMDX(APCHSDFN)=""
Begin DoDot:1
+14 IF $$AGE^AUPNPAT(APCHSDFN)<18
QUIT
+15 SET T=$ORDER(^ATXLAB("B","DM AUDIT GLUCOSE TESTS TAX",0))
IF $GET(T)]""
SET APCHLGLV=$$LAB(APCHSDFN,T)
SET APCHLGLD=$PIECE($GET(APCHLGLV),"|||",2)
SET APCHLGLV=$PIECE($GET(APCHLGLV),"|||")
Begin DoDot:2
+16 IF $GET(APCHLGLV)']""
SET X=""
SET $EXTRACT(X,5)="No Blood Sugar on file - should be done now."
DO S(X)
QUIT
+17 IF APCHLGLV]""
SET X=""
SET $EXTRACT(X,5)="Last Blood Sugar: "_APCHLGLV_" ("_APCHLGLD_")"
DO S(X)
+18 IF APCHLGLD]""
SET X=APCHLGLD
DO ^%DT
SET APCHLGLD=Y
SET X1=DT
SET X2=APCHLGLD
IF $$FMDIFF^XLFDT(X1,X2)>730
SET X=""
SET $EXTRACT(X,5)="Since it's been over 2 years - time to do this test again."
DO S(X)
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;
IMMUN ;Immunizaitons
+1 SET X="IMMUNIZATIONS(SHOTS) Getting shots protects you from some diseases and"
DO S(X,1)
+2 SET X="illnesses."
DO S(X)
+3 ;
+4 DO IMMFORC^BIRPC(.APCHIMM,APCHSDFN)
+5 IF $EXTRACT($GET(APCHIMM),1,2)="No"
SET X=""
SET $EXTRACT(X,5)="Good news! Your immunizations are up to date"
DO S(X)
+6 IF $EXTRACT($GET(APCHIMM),1,2)=" "
FOR APCHIMMN=1:1
SET APCHIMMT=$PIECE($PIECE(APCHIMM,U,APCHIMMN),"|")
IF $GET(APCHIMMT)']""
QUIT
Begin DoDot:1
+7 IF $EXTRACT(APCHIMMT,1,2)=" "
SET APCHIMMT=$EXTRACT(APCHIMMT,3,99)
+8 IF $GET(APCHIMMT)]""
SET APCHI(APCHIMMN)=APCHIMMT
+9 QUIT
End DoDot:1
+10 IF $GET(APCHIMM)]""
IF +APCHIMM
SET X=""
SET $EXTRACT(X,5)="Immunizations are due."
DO S(X)
+11 IF $DATA(APCHI)
SET APCHICTR=0
Begin DoDot:1
+12 SET X=""
SET $EXTRACT(X,5)="Immunizations due:"
DO S(X)
+13 FOR
SET APCHICTR=$ORDER(APCHI(APCHICTR))
IF APCHICTR'=+APCHICTR
QUIT
Begin DoDot:2
+14 SET APCHIMDU=$PIECE(APCHI(APCHICTR),U)
SET X=""
SET $EXTRACT(X,5)=APCHIMDU
DO S(X)
+15 QUIT
End DoDot:2
End DoDot:1
+16 ;
CRECTAL ;Colorectal screening
+1 IF $$AGE^AUPNPAT(APCHSDFN)>50
Begin DoDot:1
+2 ;has CRC dx
IF $$CRC(APCHSDFN,DT)=1
QUIT
+3 SET X="COLORECTAL SCREENING This test may show cancer, even when you feel ok."
DO S(X,1)
+4 SET APCHLFOB=$$LASTFOBT^APCLAPI3(APCHSDFN)
SET APCHLBE=$$LASTBE^APCLAPI4(APCHSDFN)
SET APCHLCOL=$$LASTCOLO^APCLAPI(APCHSDFN)
SET APCHLSIG=$$LASTFSIG^APCLAPI(APCHSDFN)
+5 SET APCHLDRE=$$LASTRECT^APCLAPI2(APCHSDFN)
+6 SET APCHSCRN=""
+7 IF $GET(APCHLDRE)]""
SET APCHSCRN=APCHLDRE
IF $$FMDIFF^XLFDT(DT,APCHLDRE)<720
SET APCHCOLO=1
+8 IF $GET(APCHLFOB)]""
IF APCHLFOB>APCHSCRN
SET APCHSCRN=APCHLFOB
IF $$FMDIFF^XLFDT(DT,APCHLFOB)<720
SET APCHCOLO=1
+9 IF $GET(APCHLCOL)]""
IF APCHLCOL>APCHSCRN
SET APCHSCRN=APCHLCOL
IF $$FMDIFF^XLFDT(DT,APCHLCOL)<3650
SET APCHCOLO=1
+10 IF $GET(APCHLBE)]""
IF APCHLBE>APCHSCRN
SET APCHSCRN=APCHLBE
IF $$FMDIFF^XLFDT(DT,APCHLBE)<1825
SET APCHCOLO=1
+11 IF $GET(APCHLSIG)]""
IF APCHLSIG>APCHSCRN
SET APCHSCRN=APCHLSIG
IF $$FMDIFF^XLFDT(DT,APCHLSIG)<1825
SET APCHCOLO=1
+12 IF $GET(APCHSCRN)]""
SET X=""
SET $EXTRACT(X,5)="Your last colorectal screening was performed on "_$$FMTE^XLFDT(APCHSCRN)
DO S(X)
+13 IF $GET(APCHCOLO)'=1
SET X=""
SET $EXTRACT(X,5)="Your colorectal screening is due now"
DO S(X)
End DoDot:1
+14 ;
WOMENS ;Womens health issues
+1 ;first get cervical and breast needs from BW package
+2 SET APCHPNV=$$VAL^XBDIQ1(9002086,APCHSDFN,.11)
IF $GET(APCHPNV)["PAP"
SET APCHPND=$$VALI^XBDIQ1(9002086,APCHSDFN,.12)
+3 SET APCHMNV=$$VAL^XBDIQ1(9002086,APCHSDFN,.18)
IF $GET(APCHMNV)["Mammo"!($GET(APCHMNV)["MAM")
SET APCHMND=$$VALI^XBDIQ1(9002086,APCHSDFN,.19)
+4 ;now check last PAP and mammogram
+5 IF $$SEX^AUPNPAT(APCHSDFN)="F"
IF $$AGE^AUPNPAT(APCHSDFN)>18
IF $$AGE^AUPNPAT(APCHSDFN)<66
SET X="MAMMOGRAM and PAP SCREEN These may show cancer even when you feel ok."
DO S(X,1)
Begin DoDot:1
+6 SET APCHSPAP=$$LASTPAP^APCLAPI1(APCHSDFN)
IF APCHSPAP]""
SET X=""
SET $EXTRACT(X,5)="Your last PAP was performed on "_$$FMTE^XLFDT($$LASTPAP^APCHSMU(APCHSDFN))
DO S(X,1)
+7 IF $GET(APCHPNV)']""
IF APCHSPAP]""
SET X1=DT
SET X2=APCHSPAP
IF $$FMDIFF^XLFDT(X1,X2)>1095
SET X=""
SET $EXTRACT(X,5)="Your PAP is due now"
DO S(X)
+8 IF '$GET(APCHPND)
IF APCHSPAP=""
SET X=""
SET $EXTRACT(X,5)="Your PAP is due now"
DO S(X,1)
+9 IF $GET(APCHPND)]""
IF APCHPND<DT
IF APCHPND>APCHSPAP
SET X=""
SET $EXTRACT(X,5)="Your PAP is due now"
DO S(X)
+10 IF $$AGE^AUPNPAT(APCHSDFN)>49
Begin DoDot:2
+11 SET APCHMAM=$$LASTMAM^APCLAPI1(APCHSDFN)
IF APCHSMAM]""
SET X=""
SET $EXTRACT(X,5)="Your last mammogram was performed on "_$$FMTE^XLFDT(APCHSMAM)
DO S(X)
+12 IF $GET(APCHMNV)']""
IF APCHSMAM]""
SET X1=DT
SET X2=APCHSMAM
IF $$FMDIFF^XLFDT(X1,X2)>365
SET X=""
SET $EXTRACT(X,5)="Your mammogram is due now"
DO S(X)
+13 IF APCHSMAM=""
SET X=""
SET $EXTRACT(X,5)="Your mammogram is due now"
DO S(X)
+14 IF $GET(APCHMND)]""
IF APCHMND<DT
IF APCHMND>APCHSMAM
SET X=""
SET $EXTRACT(X,5)="Your mammogram is due now"
DO S(X)
+15 ;WH MAM need date not updated
IF $GET(APCHMND)]""
IF APCHMND<DT
IF APCHMND=APCHSMAM
SET X=""
SET $EXTRACT(X,5)="Your mammogram is due now"
DO S(X)
End DoDot:2
End DoDot:1
+16 ;
+17 IF $$SEX^AUPNPAT(APCHSDFN)="F"
IF $$AGE^AUPNPAT(APCHSDFN)>40
IF $$AGE^AUPNPAT(APCHSDFN)<50
IF APCHSMAM=""
SET X=""
SET $EXTRACT(X,5)="Your mammogram is due at age 50"
DO S(X)
+18 ;
HEARING ;
+1 IF $$AGE^AUPNPAT(APCHSDFN)>64
Begin DoDot:1
+2 SET X="HEARING TEST This may show loss of good hearing - and if a hearing aid"
DO S(X,1)
+3 SET X="would help."
DO S(X)
+4 ;get hearing test history
+5 IF $$LASTHEAR^APCLAPI3(APCHSDFN)]""
SET X=""
SET $EXTRACT(X,5)="Your last hearing test was performed on "_$$FMTE^XLFDT($$LASTHEAR^APCLAPI3(APCHSDFN))
DO S(X,1)
+6 IF $$LASTHEAR^APCLAPI3(APCHSDFN)=""
SET X=""
SET $EXTRACT(X,5)="Your hearing test is due now"
DO S(X,1)
+7 QUIT
End DoDot:1
+8 ;
+9 SET X=""
SET $EXTRACT(X,5)="Ask your provider about ways you can stay healthy."
DO S(X,2)
+10 ;
HABITS ;
+1 SET X="HEALTH HABITS"
DO S(X,1)
+2 SET X="Please answer the questions. Mark the box next to your answer."
DO S(X,1)
+3 SET X="FEELING SAD"
DO S(X,1)
+4 SET X="During the past month, have you felt down, depressed, or hopeless?"
DO S(X)
+5 SET X=""
SET $EXTRACT(X,5)="[ ] Yes"
SET $EXTRACT(X,15)="[ ] No"
DO S(X)
+6 SET X="During the past month, have you felt little interest or pleasure in"
DO S(X)
+7 SET X="doing things you used to like to do?"
DO S(X)
+8 SET X=""
SET $EXTRACT(X,5)="[ ] Yes"
SET $EXTRACT(X,15)="[ ] No"
DO S(X)
+9 SET X="ALCOHOL USE"
DO S(X,1)
+10 SET X="In the past year, how often do you drink? A drink is one bottle of beer,"
DO S(X)
+11 SET X="one glass of wine, one wine cooler, one cocktail or one shot of hard liquor"
DO S(X)
+12 SET X="(like whiskey, scotch, gin or vodka)."
DO S(X)
+13 SET X=""
SET $EXTRACT(X,5)="[ ] Never"
SET $EXTRACT(X,25)="[ ] Monthly or less"
SET $EXTRACT(X,45)="[ ] 2-4 times/month"
DO S(X)
+14 SET X=""
SET $EXTRACT(X,5)="[ ] 2-3 times/week"
SET $EXTRACT(X,25)="[ ] 4-5 times/week"
SET $EXTRACT(X,45)="[ ] 6+ days/week"
DO S(X)
+15 SET X="When you drink, about how many drinks do you have?"
DO S(X,1)
+16 SET X=""
SET $EXTRACT(X,5)="[ ] 0 drinks"
SET $EXTRACT(X,25)="[ ] 1-2 drinks"
SET $EXTRACT(X,45)="[ ] 3-4 drinks"
DO S(X)
+17 SET X=""
SET $EXTRACT(X,5)="[ ] 5-6 drinks"
SET $EXTRACT(X,25)="[ ] 7-9 drinks"
SET $EXTRACT(X,45)="[ ] 10+ drinks"
DO S(X)
+18 SET X="How many times in the past year did you have "_$SELECT($$SEX^AUPNPAT(APCHSDFN)="M":"6 or more drinks in one day?",1:"4 or more drinks in one day?")
DO S(X,1)
+19 SET X=""
SET $EXTRACT(X,5)="[ ] Never"
SET $EXTRACT(X,25)="[ ] Monthly"
SET $EXTRACT(X,45)="[ ] Less than monthly"
DO S(X)
+20 SET X=""
SET $EXTRACT(X,5)="[ ] Weekly"
SET $EXTRACT(X,25)="[ ] Daily or almost daily"
DO S(X)
+21 SET X="TOBACCO"
DO S(X,1)
+22 SET X="Mark the answers which best describe your smoking history."
DO S(X)
+23 SET X=""
SET $EXTRACT(X,5)="[ ] Never used tobacco(lifetime non-tobacco user)"
DO S(X)
+24 SET X=""
SET $EXTRACT(X,5)="[ ] Current Smoker (cigarettes or cigars)"
DO S(X)
+25 SET X=""
SET $EXTRACT(X,10)="[ ] Trying to quit smoking"
DO S(X)
+26 SET X=""
SET $EXTRACT(X,5)="[ ] Current chewing (smokeless) tobacco user"
DO S(X)
+27 SET X=""
SET $EXTRACT(X,10)="[ ] Trying to quit chewing"
DO S(X)
+28 SET X=""
SET $EXTRACT(X,5)="[ ] Used to smoke - but quit"
DO S(X)
+29 SET X=""
SET $EXTRACT(X,5)="[ ] Used to chew - but quit"
DO S(X)
+30 SET X=""
SET $EXTRACT(X,5)="[ ] Only use for religious or cultural reasons"
DO S(X)
+31 SET X="Does anyone smoke at your home? [ ] Yes [ ] No"
DO S(X)
+32 IF $$SEX^AUPNPAT(APCHSDFN)="M"
QUIT
+33 IF $$AGE^AUPNPAT(APCHSDFN)<16
QUIT
+34 SET X="FAMILY PLANNING"
DO S(X,1)
+35 SET X="Are you planning to have a baby this week, this month, this year? [ ] Yes [ ] No"
DO S(X)
+36 SET X="Do you or your partner use a form of birth control? [ ] Yes [ ] No"
DO S(X)
+37 SET X=""
SET $EXTRACT(X,5)="[ ] Condom [ ] Diaphragm [ ] Birth Control Pills [ ] Sterilization"
DO S(X)
+38 SET X=""
SET $EXTRACT(X,5)="[ ] Rhythm Method [ ] A shot [ ] Other [ ] I do not use birth control"
DO S(X)
+39 QUIT
+40 ;
+41 ;
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)+1
SET $PIECE(^TMP("APCHPHS",$JOB,"PHS",0),U)=%
+2 SET ^TMP("APCHPHS",$JOB,"PHS",%)=X
+3 QUIT
DMDX(P) ;
+1 ;check problem list OR must have 3 diagnoses
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+3 IF 'T
QUIT ""
+4 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^ATXAPI(Y,T,9)
SET I=1
+5 IF I
QUIT "Yes"
+6 NEW APCHX
+7 SET APCHX=""
+8 SET X=P_"^LAST 3 DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,"APCHX(")
IF E
GOTO DMX
IF $DATA(APCHX(3))
SET APCHX="Yes"
+9 IF '$DATA(APCHX)=""
SET APCHX="No"
DMX ;
+1 QUIT APCHX
+2 ;
LAB(P,T,LT) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 NEW D,V,G,X,J
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+5 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=Y
QUIT
+6 IF 'LT
QUIT
+7 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+8 IF '$$LOINC(J,LT)
QUIT
+9 SET G=Y
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF 'G
SET R=$$REF(P,T)
QUIT "||||||"_R
+14 QUIT $PIECE(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_$$REF(P,T,$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_G
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
DATE(D) ;EP - convert to slashed date
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(D)
SET D=""
+4 NEW APCHREF,APCHT,V
SET APCHT=0
FOR
SET APCHT=$ORDER(^ATXLAB(T,21,"B",APCHT))
IF APCHT'=+APCHT
QUIT
Begin DoDot:1
+5 SET V=$$REF1(P,60,APCHT,D)
IF V]""
SET APCHREF(9999999-$PIECE(V,U,3))=V
End DoDot:1
+6 IF $DATA(APCHREF)
SET %=0
SET %=$ORDER(APCHREF(%))
IF %
SET V=APCHREF(%)
QUIT V
+7 QUIT ""
REF1(P,F,I,D,T) ; ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(D)=""
SET D=""
+5 IF $GET(T)=""
SET T="E"
+6 NEW X,N
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+7 ;none of this item was refused
IF 'X
QUIT ""
+8 SET N=$ORDER(^AUPNPREF("AA",P,F,I,X,0))
+9 NEW Y
SET Y=9999999-X
+10 IF D]""
IF Y>D
QUIT $SELECT(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
+11 ;quit on internal form of date
IF T="I"
QUIT Y
+12 QUIT $$TYPEREF(N)_"-"_$$DATE(Y)
+13 ;
TYPEREF(N) ;
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Refused"
+3 IF %="N"
QUIT "Not Med Ind"
+4 IF %="F"
QUIT "No Resp to F/U"
+5 QUIT ""
+6 ;
CRC(P,EDATE) ;
+1 KILL APCHG
+2 SET Y="APCHG("
+3 SET X=P_"^LAST DX [BGP COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 ;has dx
IF $DATA(APCHG(1))
QUIT 1
+5 QUIT 0
+6 ;
