APCHPWH3 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
;
;
MEDS ;EP - medications component
;get all meds in the past year +30 days
NEW APCHMEDS,APCHMED,X,M,I,N,D,APCHKEEP,APCHGRP,APCHRXN,APCHRXO,APCHRX0,APCHSREF,APCHSTAT,C,APCHN,APCHI,APCHD,APCHC
NEW X,M,D,N,C,Z,P,I
;
S APCHMEDS=""
D GETMEDS^APCHSMU1(APCHSDFN,$$FMADD^XLFDT(DT,-395),DT,,,,,.APCHMEDS)
;store each drug by inverse date
K APCHMED
S X=0 F S X=$O(APCHMEDS(X)) Q:X'=+X D
.S M=$P(APCHMEDS(X),U,4)
.S D=$P(^AUPNVMED(M,0),U,1)
.S N=$S($P(^AUPNVMED(M,0),U,4)]"":$P(^AUPNVMED(M,0),U,4),1:$P(^PSDRUG(D,0),U,1))
.S APCHMED(N,D,(9999999-$P(APCHMEDS(X),U,1)))=APCHMEDS(X)
;now get rid of all except the latest one
K APCHKEEP
S N="" F S N=$O(APCHMED(N)) Q:N="" D
.S D=0 F S D=$O(APCHMED(N,D)) Q:D="" D
..Q:$D(APCHKEEP(N,D))
..S X=$O(APCHMED(N,D,0))
..S APCHKEEP(N,D,X)=APCHMED(N,D,X)
;
;now put into groups
K APCHGRP
S N="" F S N=$O(APCHKEEP(N)) Q:N="" D
.S D=0 F S D=$O(APCHKEEP(N,D)) Q:D="" D
..S X=0 F S X=$O(APCHKEEP(N,D,X)) Q:X'=+X D
...;get status, if expired or discontinued put in group 2, 3 all others go in group 1
...;skip 1,2,4,10,13,15
...S M=$P(APCHKEEP(N,D,X),U,4)
...S Z=""
...S APCHRXN=$O(^PSRX("APCC",M,0))
...I APCHRXN D Q
....S APCHSTAT=$P($G(^PSRX(APCHRXN,"STA")),U,1)
....Q:APCHSTAT=""
....Q:APCHSTAT=1
....Q:APCHSTAT=2
....Q:APCHSTAT=4
....Q:APCHSTAT=10
....Q:APCHSTAT=13
....Q:APCHSTAT=15
....S C=$S(+APCHRXN:$D(^PS(55,APCHSDFN,"P","CP",APCHRXN)),1:0)
....S I=$S(C:120,1:14)
....I APCHSTAT=11 D Q
.....Q:$$FMDIFF^XLFDT(DT,$P($G(^PSRX(APCHRXN,2)),U,6))>I
.....S APCHGRP(2,N,D,X)=APCHKEEP(N,D,X),$P(APCHGRP(2,N,D,X),U,10)=$P($G(^PSRX(APCHRXN,2)),U,6) S Z=2 D SET Q
....S C=$S(+APCHRXN:$D(^PS(55,APCHSDFN,"P","CP",APCHRXN)),1:0)
....S I=31
....I APCHSTAT=12!(APCHSTAT=14)&($$FMDIFF^XLFDT(DT,$P(^AUPNVMED(M,0),U,8))<I) S APCHGRP(3,N,D,X)=APCHKEEP(N,D,X),$P(APCHGRP(3,N,D,X),U,12)=$P(^AUPNVMED(M,0),U,8) S Z=3 D SET Q
....I APCHSTAT=12!(APCHSTAT=14) Q ;only past 30/120 days
....S APCHGRP(1,N,D,X)=APCHKEEP(N,D,X) S Z=1 D SET
....I APCHSTAT=3 S $P(APCHGRP(1,N,D,X),U,11)=$P($G(^PSRX(APCHRXN,"H")),U,1)
...S APCHGRP(1,N,D,X)=APCHKEEP(N,D,X) S Z=1 D SET1
...Q
..Q
.Q
S D=DT
F S D=$O(^PS(55,APCHSDFN,"P","A",D)) Q:D'=+D D
.S N=0 F S N=$O(^PS(55,APCHSDFN,"P","A",D,N)) Q:'N D
..Q:'$$HOLD(N)
..S X=$$VAL^XBDIQ1(52,N,6)
..S APCHGRP(1,X,$P(^PSRX(N,0),U,6),D)=D_U_$$VAL^XBDIQ1(52,N,6)_U_$$VAL^XBDIQ1(52,N,6)
..S $P(APCHGRP(1,X,$P(^PSRX(N,0),U,6),D),U,11)=$$EXTSET^XBFUNC(52,99,$P($G(^PSRX(N,"H")),U,1))
..S $P(APCHGRP(1,X,$P(^PSRX(N,0),U,6),D),U,13)=N
;get pending order
;S P=APCHSDFN_";DPT("
;S D=0 F S D=$O(^OR(100,"AC",P,D)) Q:D'=+D D
;.S I=0 F S I=$O(^OR(100,"AC",P,D,I)) Q:I'=+I D
;..S G=$$VALI^XBDIQ1(100,I,12)
;..Q:'G
;..Q:$P($G(^DIC(9.4,G,0)),U,2)'="PSO"
;..Q:$$VAL^XBDIQ1(100,I,5)'="PENDING"
;..S X=0 F S X=$O(^OR(100,I,.1,X)) Q:X'=+X D
;...S N=$P(^OR(100,I,.1,X,0),U) I N]"" S N=$P($G(^OR(101.43,N,0)),U)
;...I N S APCHGRP(1.5,N,99,(9999999-$P(D,".")))=(9999999-$P(D,"."))_U_N
;display them now, this was a pain
D SUBHEAD^APCHPWHU
D S^APCHPWH1("MEDICATIONS - This is a list of medications and other items you are")
D S^APCHPWH1("taking including non-prescription medications, herbal, dietary, and")
D S^APCHPWH1("traditional supplements. Please let us know if this list is not ")
D S^APCHPWH1("complete.")
I '$D(APCHGRP) D S^APCHPWH1("No medications are on file. Please tell us if there are any that we missed.",1) Q
S APCHC=0
S APCHN=""
F S APCHN=$O(APCHGRP(1,APCHN)) Q:APCHN="" D
.S APCHI=0 F S APCHI=$O(APCHGRP(1,APCHN,APCHI)) Q:APCHI'=+APCHI D
..S APCHD=0 F S APCHD=$O(APCHGRP(1,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD D
...S Z=APCHGRP(1,APCHN,APCHI,APCHD)
...S APCHC=APCHC+1
...S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(Z,U,6)]"":"Rx#: "_$P(Z,U,6),1:""),$E(X,61)=$S($P(Z,U,7)]"":"Refills left: "_$P(Z,U,7),1:"") D S^APCHPWH1(X,1)
...;attempt to wrap directions 58 characters
...K ^UTILITY($J,"W") S X=$P(Z,U,8),DIWL=0,DIWR=58 D ^DIWP
...S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
...I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
...K ^UTILITY($J,"W")
...I $P(Z,U,11)]"" D S^APCHPWH1(" Ordered but not dispensed: "_$P(Z,U,11))
I $D(APCHGRP(2)) D
.D S^APCHPWH1("==========",1)
.D S^APCHPWH1("Your prescription for these medications has expired. You need to talk")
.D S^APCHPWH1("with your prescriber to get a new prescription for these medications.")
.D S^APCHPWH1(" ")
.S APCHN="" F S APCHN=$O(APCHGRP(2,APCHN)) Q:APCHN="" D
..S APCHI=0 F S APCHI=$O(APCHGRP(2,APCHN,APCHI)) Q:APCHI'=+APCHI D
...S APCHD=0 F S APCHD=$O(APCHGRP(2,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD D
....S Z=APCHGRP(2,APCHN,APCHI,APCHD)
....S APCHC=APCHC+1
....S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(Z,U,6)]"":"Rx#: "_$P(Z,U,6),1:""),$E(X,61)=$S($P(Z,U,7)]"":"Refills left: "_$P(Z,U,7),1:"") D S^APCHPWH1(X,1)
....;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
....K ^UTILITY($J,"W") S X=$P(Z,U,8),DIWL=0,DIWR=58 D ^DIWP
....S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
....I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
....K ^UTILITY($J,"W")
....S X="",$E(X,7)="Last date filled: "_$$FMTE^XLFDT($P(Z,U))_" Expired on: "_$$FMTE^XLFDT($P(Z,U,10)) D S^APCHPWH1(X)
I $D(APCHGRP(3)) D
.D S^APCHPWH1("==========",1)
.D S^APCHPWH1("These medications have been stopped. You should not take these")
.D S^APCHPWH1("medications. Talk to your pharmacist about ways to safely get rid")
.D S^APCHPWH1("of these medications if you have them at home.")
.D S^APCHPWH1(" ")
.S APCHN="" F S APCHN=$O(APCHGRP(3,APCHN)) Q:APCHN="" D
..S APCHI=0 F S APCHI=$O(APCHGRP(3,APCHN,APCHI)) Q:APCHI'=+APCHI D
...S APCHD=0 F S APCHD=$O(APCHGRP(3,APCHN,APCHI,APCHD)) Q:APCHD'=+APCHD D
....S Z=APCHGRP(3,APCHN,APCHI,APCHD)
....S APCHC=APCHC+1
....S X="",$E(X,1)=APCHC_".",$E(X,7)=APCHN,$E(X,47)=$S($P(Z,U,6)]"":"Rx#: "_$P(Z,U,6),1:""),$E(X,61)=$S($P(Z,U,7)]"":"Refills left: "_$P(Z,U,7),1:"") D S^APCHPWH1(X,1)
....;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
....K ^UTILITY($J,"W") S X=$P(Z,U,8),DIWL=0,DIWR=58 D ^DIWP
....S X="",$E(X,7)="Directions: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"No directions on file",1:" ") D S^APCHPWH1(X)
....I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,19)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
....K ^UTILITY($J,"W")
....S X="",$E(X,7)="Discontinued on: "_$$FMTE^XLFDT($P(Z,U,12)) D S^APCHPWH1(X)
Q
;
SET1 ;
S $P(APCHGRP(Z,N,D,X),U,6)=$P($G(^AUPNVMED(M,11)),U,2)
S $P(APCHGRP(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5)
S $P(APCHGRP(Z,N,D,X),U,7)=$P($G(^AUPNVMED(M,11)),U,7)
Q
SET ;
S $P(APCHGRP(Z,N,D,X),U,6)=$P(^PSRX(APCHRXN,0),U)
S $P(APCHGRP(Z,N,D,X),U,8)=$P(^AUPNVMED(M,0),U,5)
S APCHSRX=APCHRXN,APCHSREF=0 D REF^APCHS7O S $P(APCHGRP(Z,N,D,X),U,7)=APCHSREF
Q
HOLD(S) ;EP - is this prescription on hold?
NEW X
S X=$P($G(^PSRX(S,"STA")),U,1)
I X=3 Q 1
;I X=5 Q 1
;I X=16 Q 1
;version 6
S X=$P($G(^PSRX(S,0)),U,15)
I X=3 Q 1
;I X=5 Q 1
;I X=16 Q 1
Q 0
;
;
HIV ;EP - HIV component
I $$AGE^AUPNPAT(APCHSDFN,DT)<13 Q
I $$AGE^AUPNPAT(APCHSDFN,DT)>64 Q
Q:$$HIVDX(DFN,DT)
NEW APCHHIVT,APCH5Y,B
S B=$$DOB^AUPNPAT(APCHSDFN)
S APCH5Y=($E(DT,1,3)-5)_$E(DT,4,7)
S APCHHIVT=$$HIVTEST(APCHSDFN,APCH5Y,DT)
I APCHHIVT Q ;had a test
D SUBHEAD^APCHPWHU
D S^APCHPWH1("SCREEN FOR HUMAN IMMUNODEFICIENCY VIRUS (HIV)")
D S^APCHPWH1("HIV is a virus that causes a serious infection. HIV infection")
D S^APCHPWH1("can cause sickness and death. A person can have HIV for many years")
D S^APCHPWH1("and not know it. Everyone should be tested for HIV when they are")
D S^APCHPWH1("between 13 and 64 years old. According to our records, you have not")
D S^APCHPWH1("had an HIV test. Talk to your provider about how you can get an")
D S^APCHPWH1("HIV test.")
Q
;
HIVDX(P,EDATE) ; any HIV dx ever or problem list HIV dx
NEW APCHG
S Y="APCHG("
S BDATE=$$FMADD^XLFDT(EDATE,-365)
S X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(APCHG(1)) Q 1
S T=$O(^ATXAX("B","BGP HIV/AIDS DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXAPI(Y,T,9)
.S G=1
.Q
I G Q G
I $T(ATAG^BQITDUTL)]"" S X=$$ATAG^BQITDUTL(P,"HIV") I $P(X,U),($P(X,U,2)="P"!($P(X,U,2)="A")) Q 1
Q ""
;
LAB(P,T,LT,LN) ;EP
I '$G(LT) S LT=""
S LN=$G(LN)
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)) S G=Y Q
...I LN]"",$$VAL^XBDIQ1(9000010.09,Y,.01)=LN 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 Q ""
Q 1
;
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 ""
;
HIVTEST(P,BDATE,EDATE) ;
NEW APCHC,APCHT,T,X,APCHLT,E,D,B,L,J,G,APCHT1,APCHA
NEW BD,ED,Y,D,V
K APCHA
S APCHC=0
S T=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
I T D
.;go through visits in a date range for this patient, check cpts
.S ED=(9999999-EDATE),BD=9999999-BDATE,G=0
.F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
..S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
...Q:'$D(^AUPNVSIT(V,0))
...Q:'$D(^AUPNVCPT("AD",V))
...S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
....I $$ICD^ATXAPI($P(^AUPNVCPT(X,0),U),T,1) S G=1
....Q
...Q
..Q
I G Q G
S T=$O(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
S APCHLT=$O(^ATXLAB("B","BGP HIV TEST TAX",0))
S B=9999999-BDATE,E=9999999-EDATE,G=0 S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(G) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(G) D
...Q:'$D(^AUPNVLAB(X,0))
...S V=$P(^AUPNVLAB(X,0),U,3)
...I APCHLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCHLT,21,"B",$P(^AUPNVLAB(X,0),U))),'$D(APCHA((9999999-D))) S G=1 Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...I '$D(APCHA((9999999-D))) S G=1
...Q
Q G
;
GOALS ;EP
NEW APCHEDUC,X,N,APCHGOAL,APCHX,APCHY,APCHZ
D EDUC(APCHSDFN,.APCHEDUC)
D GOAL(APCHSDFN,.APCHGOAL)
D SUBHEAD^APCHPWHU
I '$D(APCHEDUC),'$D(APCHGOAL) D Q
.D S^APCHPWH1("My Healthcare Goals - No goals recorded")
D S^APCHPWH1("My Healthcare Goals")
S N="" F S N=$O(APCHEDUC(N)) Q:N="" D
.S X=""
.S Y="",Y=$P(N,"-") I Y]"" S Y=$O(^AUTTEDMT("B",Y,0)) I Y S Y=$P($G(^AUTTEDMT(Y,0)),U)
.S T=$S(Y]"":Y_"-"_$P(N,"-",2),1:N),$E(X,2)=T D S^APCHPWH1(X)
.S X="",$E(X,4)="Goal: "_$P(APCHEDUC(N),U,4) D S^APCHPWH1(X)
I $D(APCHEDUC) D S^APCHPWH1(" ")
Q:'$D(APCHGOAL)
S APCHX=0 F S APCHX=$O(APCHGOAL(APCHX)) Q:APCHX'=+APCHX D
.K ^UTILITY($J,"W") S X=$P($G(^AUPNGOAL(APCHX,11)),U,1),DIWL=0,DIWR=60 D ^DIWP
.S X="",X="Goal Name: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"This goal has not been named.",1:" ") D S^APCHPWH1(X)
.I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,12)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
.K ^UTILITY($J,"W")
.S X="",$E(X,2)="Start: "_$$FMTE^XLFDT($P(^AUPNGOAL(APCHX,0),U,9))_" Follow up: "_$$FMTE^XLFDT($P(^AUPNGOAL(APCHX,0),U,10)) D S^APCHPWH1(X)
.S X="" S APCHY=0 F S APCHY=$O(^AUPNGOAL(APCHX,10,APCHY)) Q:APCHY'=+APCHY S:X]"" X=X_", " S X=X_$P(^APCDTPGT($P(^AUPNGOAL(APCHX,10,APCHY,0),U,1),0),U,1)
.K ^UTILITY($J,"W") S DIWL=0,DIWR=65 D ^DIWP
.S X="",X=" Type: "_$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:" ",1:" ") D S^APCHPWH1(X)
.I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,9)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
.K ^UTILITY($J,"W")
.;
.S APCHY=0 F S APCHY=$O(^AUPNGOAL(APCHX,21,APCHY)) Q:APCHY'=+APCHY D
..S APCHZ=0 F S APCHZ=$O(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ)) Q:APCHZ'=+APCHZ D
...S X="",$E(X,2)="Step#"_$P(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,1)_": "_$P($G(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,11)),U,1)
...K ^UTILITY($J,"W") S DIWL=0,DIWR=60 D ^DIWP
...S X="",X=$S($L($G(^UTILITY($J,"W",0,1,0)))>1:$G(^UTILITY($J,"W",0,1,0)),$L($G(^UTILITY($J,"W",0,1,0)))=1:"This STEP has not been defined.",1:" ") D S^APCHPWH1(X)
...I $G(^UTILITY($J,"W",0))>1 F F=2:1:$G(^UTILITY($J,"W",0)) S X="",$E(X,10)=$G(^UTILITY($J,"W",0,F,0)) D S^APCHPWH1(X)
...K ^UTILITY($J,"W")
...S X=" Start: "_$$FMTE^XLFDT($P(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,5))_" Follow up: "_$$FMTE^XLFDT($P(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,6)) D S^APCHPWH1(X)
.Q
Q
EDUC(P,DATA) ;EP pass back array of all educ topics
;any topic that begins with ASM or 493
K DATA
I '$G(P) Q
NEW APCHE,X,E,%,G,A,N,D,I
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,A)
I '$D(^TMP($J,"A",1)) Q
S %=0 F S %=$O(^TMP($J,"A",%)) Q:%'=+% D
.S D=$P(^TMP($J,"A",%),U,1)
.S I=+$P(^TMP($J,"A",%),U,4)
.S N=$P(^AUPNVPED(I,0),U)
.Q:'N
.I $P(^AUPNVPED(I,0),U,14)="" Q ;only those with goal stuff
.S APCHE($P(^TMP($J,"A",%),U,2),9999999-D)=$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.06)_U_$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.13)_U_$$VAL^XBDIQ1(9000010.16,+$P(^TMP($J,"A",%),U,4),.14)
S N="" F S N=$O(APCHE(N)) Q:N="" S DATA(N)=(9999999-$O(APCHE(N,0)))_U_APCHE(N,$O(APCHE(N,0)))
K APCHE,^TMP($J,"A")
Q
;
GOAL(P,DATA) ;EP - pass back array in chronological order by start date and ien
K DATA
I '$G(P) Q
NEW APCHE,X,E,%,G,A,N,D,I
S X=0 F S X=$O(^AUPNGOAL("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNGOAL(X,0))
.Q:$P(^AUPNGOAL(X,0),U,1)="N" ;not set excluded
.Q:$P(^AUPNGOAL(X,0),U,11)="ME" ;MET
.Q:$P(^AUPNGOAL(X,0),U,11)="D" ;deleted
.Q:$P(^AUPNGOAL(X,0),U,11)="S" ;changed
.S DATA(X)=""
Q
APCHPWH3 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;**2,5,7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
MEDS ;EP - medications component
+1 ;get all meds in the past year +30 days
+2 NEW APCHMEDS,APCHMED,X,M,I,N,D,APCHKEEP,APCHGRP,APCHRXN,APCHRXO,APCHRX0,APCHSREF,APCHSTAT,C,APCHN,APCHI,APCHD,APCHC
+3 NEW X,M,D,N,C,Z,P,I
+4 ;
+5 SET APCHMEDS=""
+6 DO GETMEDS^APCHSMU1(APCHSDFN,$$FMADD^XLFDT(DT,-395),DT,,,,,.APCHMEDS)
+7 ;store each drug by inverse date
+8 KILL APCHMED
+9 SET X=0
FOR
SET X=$ORDER(APCHMEDS(X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET M=$PIECE(APCHMEDS(X),U,4)
+11 SET D=$PIECE(^AUPNVMED(M,0),U,1)
+12 SET N=$SELECT($PIECE(^AUPNVMED(M,0),U,4)]"":$PIECE(^AUPNVMED(M,0),U,4),1:$PIECE(^PSDRUG(D,0),U,1))
+13 SET APCHMED(N,D,(9999999-$PIECE(APCHMEDS(X),U,1)))=APCHMEDS(X)
End DoDot:1
+14 ;now get rid of all except the latest one
+15 KILL APCHKEEP
+16 SET N=""
FOR
SET N=$ORDER(APCHMED(N))
IF N=""
QUIT
Begin DoDot:1
+17 SET D=0
FOR
SET D=$ORDER(APCHMED(N,D))
IF D=""
QUIT
Begin DoDot:2
+18 IF $DATA(APCHKEEP(N,D))
QUIT
+19 SET X=$ORDER(APCHMED(N,D,0))
+20 SET APCHKEEP(N,D,X)=APCHMED(N,D,X)
End DoDot:2
End DoDot:1
+21 ;
+22 ;now put into groups
+23 KILL APCHGRP
+24 SET N=""
FOR
SET N=$ORDER(APCHKEEP(N))
IF N=""
QUIT
Begin DoDot:1
+25 SET D=0
FOR
SET D=$ORDER(APCHKEEP(N,D))
IF D=""
QUIT
Begin DoDot:2
+26 SET X=0
FOR
SET X=$ORDER(APCHKEEP(N,D,X))
IF X'=+X
QUIT
Begin DoDot:3
+27 ;get status, if expired or discontinued put in group 2, 3 all others go in group 1
+28 ;skip 1,2,4,10,13,15
+29 SET M=$PIECE(APCHKEEP(N,D,X),U,4)
+30 SET Z=""
+31 SET APCHRXN=$ORDER(^PSRX("APCC",M,0))
+32 IF APCHRXN
Begin DoDot:4
+33 SET APCHSTAT=$PIECE($GET(^PSRX(APCHRXN,"STA")),U,1)
+34 IF APCHSTAT=""
QUIT
+35 IF APCHSTAT=1
QUIT
+36 IF APCHSTAT=2
QUIT
+37 IF APCHSTAT=4
QUIT
+38 IF APCHSTAT=10
QUIT
+39 IF APCHSTAT=13
QUIT
+40 IF APCHSTAT=15
QUIT
+41 SET C=$SELECT(+APCHRXN:$DATA(^PS(55,APCHSDFN,"P","CP",APCHRXN)),1:0)
+42 SET I=$SELECT(C:120,1:14)
+43 IF APCHSTAT=11
Begin DoDot:5
+44 IF $$FMDIFF^XLFDT(DT,$PIECE($GET(^PSRX(APCHRXN,2)),U,6))>I
QUIT
+45 SET APCHGRP(2,N,D,X)=APCHKEEP(N,D,X)
SET $PIECE(APCHGRP(2,N,D,X),U,10)=$PIECE($GET(^PSRX(APCHRXN,2)),U,6)
SET Z=2
DO SET
QUIT
End DoDot:5
QUIT
+46 SET C=$SELECT(+APCHRXN:$DATA(^PS(55,APCHSDFN,"P","CP",APCHRXN)),1:0)
+47 SET I=31
+48 IF APCHSTAT=12!(APCHSTAT=14)&($$FMDIFF^XLFDT(DT,$PIECE(^AUPNVMED(M,0),U,8))<I)
SET APCHGRP(3,N,D,X)=APCHKEEP(N,D,X)
SET $PIECE(APCHGRP(3,N,D,X),U,12)=$PIECE(^AUPNVMED(M,0),U,8)
SET Z=3
DO SET
QUIT
+49 ;only past 30/120 days
IF APCHSTAT=12!(APCHSTAT=14)
QUIT
+50 SET APCHGRP(1,N,D,X)=APCHKEEP(N,D,X)
SET Z=1
DO SET
+51 IF APCHSTAT=3
SET $PIECE(APCHGRP(1,N,D,X),U,11)=$PIECE($GET(^PSRX(APCHRXN,"H")),U,1)
End DoDot:4
QUIT
+52 SET APCHGRP(1,N,D,X)=APCHKEEP(N,D,X)
SET Z=1
DO SET1
+53 QUIT
End DoDot:3
+54 QUIT
End DoDot:2
+55 QUIT
End DoDot:1
+56 SET D=DT
+57 FOR
SET D=$ORDER(^PS(55,APCHSDFN,"P","A",D))
IF D'=+D
QUIT
Begin DoDot:1
+58 SET N=0
FOR
SET N=$ORDER(^PS(55,APCHSDFN,"P","A",D,N))
IF 'N
QUIT
Begin DoDot:2
+59 IF '$$HOLD(N)
QUIT
+60 SET X=$$VAL^XBDIQ1(52,N,6)
+61 SET APCHGRP(1,X,$PIECE(^PSRX(N,0),U,6),D)=D_U_$$VAL^XBDIQ1(52,N,6)_U_$$VAL^XBDIQ1(52,N,6)
+62 SET $PIECE(APCHGRP(1,X,$PIECE(^PSRX(N,0),U,6),D),U,11)=$$EXTSET^XBFUNC(52,99,$PIECE($GET(^PSRX(N,"H")),U,1))
+63 SET $PIECE(APCHGRP(1,X,$PIECE(^PSRX(N,0),U,6),D),U,13)=N
End DoDot:2
End DoDot:1
+64 ;get pending order
+65 ;S P=APCHSDFN_";DPT("
+66 ;S D=0 F S D=$O(^OR(100,"AC",P,D)) Q:D'=+D D
+67 ;.S I=0 F S I=$O(^OR(100,"AC",P,D,I)) Q:I'=+I D
+68 ;..S G=$$VALI^XBDIQ1(100,I,12)
+69 ;..Q:'G
+70 ;..Q:$P($G(^DIC(9.4,G,0)),U,2)'="PSO"
+71 ;..Q:$$VAL^XBDIQ1(100,I,5)'="PENDING"
+72 ;..S X=0 F S X=$O(^OR(100,I,.1,X)) Q:X'=+X D
+73 ;...S N=$P(^OR(100,I,.1,X,0),U) I N]"" S N=$P($G(^OR(101.43,N,0)),U)
+74 ;...I N S APCHGRP(1.5,N,99,(9999999-$P(D,".")))=(9999999-$P(D,"."))_U_N
+75 ;display them now, this was a pain
+76 DO SUBHEAD^APCHPWHU
+77 DO S^APCHPWH1("MEDICATIONS - This is a list of medications and other items you are")
+78 DO S^APCHPWH1("taking including non-prescription medications, herbal, dietary, and")
+79 DO S^APCHPWH1("traditional supplements. Please let us know if this list is not ")
+80 DO S^APCHPWH1("complete.")
+81 IF '$DATA(APCHGRP)
DO S^APCHPWH1("No medications are on file. Please tell us if there are any that we missed.",1)
QUIT
+82 SET APCHC=0
+83 SET APCHN=""
+84 FOR
SET APCHN=$ORDER(APCHGRP(1,APCHN))
IF APCHN=""
QUIT
Begin DoDot:1
+85 SET APCHI=0
FOR
SET APCHI=$ORDER(APCHGRP(1,APCHN,APCHI))
IF APCHI'=+APCHI
QUIT
Begin DoDot:2
+86 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHGRP(1,APCHN,APCHI,APCHD))
IF APCHD'=+APCHD
QUIT
Begin DoDot:3
+87 SET Z=APCHGRP(1,APCHN,APCHI,APCHD)
+88 SET APCHC=APCHC+1
+89 SET X=""
SET $EXTRACT(X,1)=APCHC_"."
SET $EXTRACT(X,7)=APCHN
SET $EXTRACT(X,47)=$SELECT($PIECE(Z,U,6)]"":"Rx#: "_$PIECE(Z,U,6),1:"")
SET $EXTRACT(X,61)=$SELECT($PIECE(Z,U,7)]"":"Refills left: "_$PIECE(Z,U,7),1:"")
DO S^APCHPWH1(X,1)
+90 ;attempt to wrap directions 58 characters
+91 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(Z,U,8)
SET DIWL=0
SET DIWR=58
DO ^DIWP
+92 SET X=""
SET $EXTRACT(X,7)="Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" ")
DO S^APCHPWH1(X)
+93 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,19)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+94 KILL ^UTILITY($JOB,"W")
+95 IF $PIECE(Z,U,11)]""
DO S^APCHPWH1(" Ordered but not dispensed: "_$PIECE(Z,U,11))
End DoDot:3
End DoDot:2
End DoDot:1
+96 IF $DATA(APCHGRP(2))
Begin DoDot:1
+97 DO S^APCHPWH1("==========",1)
+98 DO S^APCHPWH1("Your prescription for these medications has expired. You need to talk")
+99 DO S^APCHPWH1("with your prescriber to get a new prescription for these medications.")
+100 DO S^APCHPWH1(" ")
+101 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHGRP(2,APCHN))
IF APCHN=""
QUIT
Begin DoDot:2
+102 SET APCHI=0
FOR
SET APCHI=$ORDER(APCHGRP(2,APCHN,APCHI))
IF APCHI'=+APCHI
QUIT
Begin DoDot:3
+103 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHGRP(2,APCHN,APCHI,APCHD))
IF APCHD'=+APCHD
QUIT
Begin DoDot:4
+104 SET Z=APCHGRP(2,APCHN,APCHI,APCHD)
+105 SET APCHC=APCHC+1
+106 SET X=""
SET $EXTRACT(X,1)=APCHC_"."
SET $EXTRACT(X,7)=APCHN
SET $EXTRACT(X,47)=$SELECT($PIECE(Z,U,6)]"":"Rx#: "_$PIECE(Z,U,6),1:"")
SET $EXTRACT(X,61)=$SELECT($PIECE(Z,U,7)]"":"Refills left: "_$PIECE(Z,U,7),1:"")
DO S^APCHPWH1(X,1)
+107 ;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
+108 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(Z,U,8)
SET DIWL=0
SET DIWR=58
DO ^DIWP
+109 SET X=""
SET $EXTRACT(X,7)="Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" ")
DO S^APCHPWH1(X)
+110 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,19)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+111 KILL ^UTILITY($JOB,"W")
+112 SET X=""
SET $EXTRACT(X,7)="Last date filled: "_$$FMTE^XLFDT($PIECE(Z,U))_" Expired on: "_$$FMTE^XLFDT($PIECE(Z,U,10))
DO S^APCHPWH1(X)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+113 IF $DATA(APCHGRP(3))
Begin DoDot:1
+114 DO S^APCHPWH1("==========",1)
+115 DO S^APCHPWH1("These medications have been stopped. You should not take these")
+116 DO S^APCHPWH1("medications. Talk to your pharmacist about ways to safely get rid")
+117 DO S^APCHPWH1("of these medications if you have them at home.")
+118 DO S^APCHPWH1(" ")
+119 SET APCHN=""
FOR
SET APCHN=$ORDER(APCHGRP(3,APCHN))
IF APCHN=""
QUIT
Begin DoDot:2
+120 SET APCHI=0
FOR
SET APCHI=$ORDER(APCHGRP(3,APCHN,APCHI))
IF APCHI'=+APCHI
QUIT
Begin DoDot:3
+121 SET APCHD=0
FOR
SET APCHD=$ORDER(APCHGRP(3,APCHN,APCHI,APCHD))
IF APCHD'=+APCHD
QUIT
Begin DoDot:4
+122 SET Z=APCHGRP(3,APCHN,APCHI,APCHD)
+123 SET APCHC=APCHC+1
+124 SET X=""
SET $EXTRACT(X,1)=APCHC_"."
SET $EXTRACT(X,7)=APCHN
SET $EXTRACT(X,47)=$SELECT($PIECE(Z,U,6)]"":"Rx#: "_$PIECE(Z,U,6),1:"")
SET $EXTRACT(X,61)=$SELECT($PIECE(Z,U,7)]"":"Refills left: "_$PIECE(Z,U,7),1:"")
DO S^APCHPWH1(X,1)
+125 ;S X="",$E(X,7)="Directions: "_$P(Z,U,8) D S^APCHPWH1(X)
+126 KILL ^UTILITY($JOB,"W")
SET X=$PIECE(Z,U,8)
SET DIWL=0
SET DIWR=58
DO ^DIWP
+127 SET X=""
SET $EXTRACT(X,7)="Directions: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"No directions on file",1:" ")
DO S^APCHPWH1(X)
+128 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,19)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+129 KILL ^UTILITY($JOB,"W")
+130 SET X=""
SET $EXTRACT(X,7)="Discontinued on: "_$$FMTE^XLFDT($PIECE(Z,U,12))
DO S^APCHPWH1(X)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+131 QUIT
+132 ;
SET1 ;
+1 SET $PIECE(APCHGRP(Z,N,D,X),U,6)=$PIECE($GET(^AUPNVMED(M,11)),U,2)
+2 SET $PIECE(APCHGRP(Z,N,D,X),U,8)=$PIECE(^AUPNVMED(M,0),U,5)
+3 SET $PIECE(APCHGRP(Z,N,D,X),U,7)=$PIECE($GET(^AUPNVMED(M,11)),U,7)
+4 QUIT
SET ;
+1 SET $PIECE(APCHGRP(Z,N,D,X),U,6)=$PIECE(^PSRX(APCHRXN,0),U)
+2 SET $PIECE(APCHGRP(Z,N,D,X),U,8)=$PIECE(^AUPNVMED(M,0),U,5)
+3 SET APCHSRX=APCHRXN
SET APCHSREF=0
DO REF^APCHS7O
SET $PIECE(APCHGRP(Z,N,D,X),U,7)=APCHSREF
+4 QUIT
HOLD(S) ;EP - is this prescription on hold?
+1 NEW X
+2 SET X=$PIECE($GET(^PSRX(S,"STA")),U,1)
+3 IF X=3
QUIT 1
+4 ;I X=5 Q 1
+5 ;I X=16 Q 1
+6 ;version 6
+7 SET X=$PIECE($GET(^PSRX(S,0)),U,15)
+8 IF X=3
QUIT 1
+9 ;I X=5 Q 1
+10 ;I X=16 Q 1
+11 QUIT 0
+12 ;
+13 ;
HIV ;EP - HIV component
+1 IF $$AGE^AUPNPAT(APCHSDFN,DT)<13
QUIT
+2 IF $$AGE^AUPNPAT(APCHSDFN,DT)>64
QUIT
+3 IF $$HIVDX(DFN,DT)
QUIT
+4 NEW APCHHIVT,APCH5Y,B
+5 SET B=$$DOB^AUPNPAT(APCHSDFN)
+6 SET APCH5Y=($EXTRACT(DT,1,3)-5)_$EXTRACT(DT,4,7)
+7 SET APCHHIVT=$$HIVTEST(APCHSDFN,APCH5Y,DT)
+8 ;had a test
IF APCHHIVT
QUIT
+9 DO SUBHEAD^APCHPWHU
+10 DO S^APCHPWH1("SCREEN FOR HUMAN IMMUNODEFICIENCY VIRUS (HIV)")
+11 DO S^APCHPWH1("HIV is a virus that causes a serious infection. HIV infection")
+12 DO S^APCHPWH1("can cause sickness and death. A person can have HIV for many years")
+13 DO S^APCHPWH1("and not know it. Everyone should be tested for HIV when they are")
+14 DO S^APCHPWH1("between 13 and 64 years old. According to our records, you have not")
+15 DO S^APCHPWH1("had an HIV test. Talk to your provider about how you can get an")
+16 DO S^APCHPWH1("HIV test.")
+17 QUIT
+18 ;
HIVDX(P,EDATE) ; any HIV dx ever or problem list HIV dx
+1 NEW APCHG
+2 SET Y="APCHG("
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+4 SET X=P_"^LAST DX [BGP HIV/AIDS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(APCHG(1))
QUIT 1
+6 SET T=$ORDER(^ATXAX("B","BGP HIV/AIDS DXS",0))
+7 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^ATXAPI(Y,T,9)
QUIT
+12 SET G=1
+13 QUIT
End DoDot:1
+14 IF G
QUIT G
+15 IF $TEXT(ATAG^BQITDUTL)]""
SET X=$$ATAG^BQITDUTL(P,"HIV")
IF $PIECE(X,U)
IF ($PIECE(X,U,2)="P"!($PIECE(X,U,2)="A"))
QUIT 1
+16 QUIT ""
+17 ;
LAB(P,T,LT,LN) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 SET LN=$GET(LN)
+3 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
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+5 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+6 IF $DATA(^ATXLAB(T,21,"B",X))
SET G=Y
QUIT
+7 IF LN]""
IF $$VAL^XBDIQ1(9000010.09,Y,.01)=LN
SET G=Y
QUIT
+8 IF 'LT
QUIT
+9 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+10 IF '$$LOINC(J,LT)
QUIT
+11 SET G=Y
+12 QUIT
End DoDot:3
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 IF 'G
QUIT ""
+16 QUIT 1
+17 ;
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 ;
HIVTEST(P,BDATE,EDATE) ;
+1 NEW APCHC,APCHT,T,X,APCHLT,E,D,B,L,J,G,APCHT1,APCHA
+2 NEW BD,ED,Y,D,V
+3 KILL APCHA
+4 SET APCHC=0
+5 SET T=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
+6 IF T
Begin DoDot:1
+7 ;go through visits in a date range for this patient, check cpts
+8 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:2
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:4
+14 IF $$ICD^ATXAPI($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=1
+15 QUIT
End DoDot:4
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 IF G
QUIT G
+19 SET T=$ORDER(^ATXAX("B","BGP HIV TEST LOINC CODES",0))
+20 SET APCHLT=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
+21 SET B=9999999-BDATE
SET E=9999999-EDATE
SET G=0
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+22 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(G)
QUIT
Begin DoDot:2
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+24 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+25 SET V=$PIECE(^AUPNVLAB(X,0),U,3)
+26 IF APCHLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCHLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF '$DATA(APCHA((9999999-D)))
SET G=1
QUIT
+27 IF 'T
QUIT
+28 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+29 IF '$$LOINC(J,T)
QUIT
+30 IF '$DATA(APCHA((9999999-D)))
SET G=1
+31 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT G
+33 ;
GOALS ;EP
+1 NEW APCHEDUC,X,N,APCHGOAL,APCHX,APCHY,APCHZ
+2 DO EDUC(APCHSDFN,.APCHEDUC)
+3 DO GOAL(APCHSDFN,.APCHGOAL)
+4 DO SUBHEAD^APCHPWHU
+5 IF '$DATA(APCHEDUC)
IF '$DATA(APCHGOAL)
Begin DoDot:1
+6 DO S^APCHPWH1("My Healthcare Goals - No goals recorded")
End DoDot:1
QUIT
+7 DO S^APCHPWH1("My Healthcare Goals")
+8 SET N=""
FOR
SET N=$ORDER(APCHEDUC(N))
IF N=""
QUIT
Begin DoDot:1
+9 SET X=""
+10 SET Y=""
SET Y=$PIECE(N,"-")
IF Y]""
SET Y=$ORDER(^AUTTEDMT("B",Y,0))
IF Y
SET Y=$PIECE($GET(^AUTTEDMT(Y,0)),U)
+11 SET T=$SELECT(Y]"":Y_"-"_$PIECE(N,"-",2),1:N)
SET $EXTRACT(X,2)=T
DO S^APCHPWH1(X)
+12 SET X=""
SET $EXTRACT(X,4)="Goal: "_$PIECE(APCHEDUC(N),U,4)
DO S^APCHPWH1(X)
End DoDot:1
+13 IF $DATA(APCHEDUC)
DO S^APCHPWH1(" ")
+14 IF '$DATA(APCHGOAL)
QUIT
+15 SET APCHX=0
FOR
SET APCHX=$ORDER(APCHGOAL(APCHX))
IF APCHX'=+APCHX
QUIT
Begin DoDot:1
+16 KILL ^UTILITY($JOB,"W")
SET X=$PIECE($GET(^AUPNGOAL(APCHX,11)),U,1)
SET DIWL=0
SET DIWR=60
DO ^DIWP
+17 SET X=""
SET X="Goal Name: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"This goal has not been named.",1:" ")
DO S^APCHPWH1(X)
+18 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,12)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+19 KILL ^UTILITY($JOB,"W")
+20 SET X=""
SET $EXTRACT(X,2)="Start: "_$$FMTE^XLFDT($PIECE(^AUPNGOAL(APCHX,0),U,9))_" Follow up: "_$$FMTE^XLFDT($PIECE(^AUPNGOAL(APCHX,0),U,10))
DO S^APCHPWH1(X)
+21 SET X=""
SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNGOAL(APCHX,10,APCHY))
IF APCHY'=+APCHY
QUIT
IF X]""
SET X=X_", "
SET X=X_$PIECE(^APCDTPGT($PIECE(^AUPNGOAL(APCHX,10,APCHY,0),U,1),0),U,1)
+22 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=65
DO ^DIWP
+23 SET X=""
SET X=" Type: "_$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:" ",1:" ")
DO S^APCHPWH1(X)
+24 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,9)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+25 KILL ^UTILITY($JOB,"W")
+26 ;
+27 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNGOAL(APCHX,21,APCHY))
IF APCHY'=+APCHY
QUIT
Begin DoDot:2
+28 SET APCHZ=0
FOR
SET APCHZ=$ORDER(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ))
IF APCHZ'=+APCHZ
QUIT
Begin DoDot:3
+29 SET X=""
SET $EXTRACT(X,2)="Step#"_$PIECE(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,1)_": "_$PIECE($GET(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,11)),U,1)
+30 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=60
DO ^DIWP
+31 SET X=""
SET X=$SELECT($LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))>1:$GET(^UTILITY($JOB,"W",0,1,0)),$LENGTH($GET(^UTILITY($JOB,"W",0,1,0)))=1:"This STEP has not been defined.",1:" ")
DO S^APCHPWH1(X)
+32 IF $GET(^UTILITY($JOB,"W",0))>1
FOR F=2:1:$GET(^UTILITY($JOB,"W",0))
SET X=""
SET $EXTRACT(X,10)=$GET(^UTILITY($JOB,"W",0,F,0))
DO S^APCHPWH1(X)
+33 KILL ^UTILITY($JOB,"W")
+34 SET X=" Start: "_$$FMTE^XLFDT($PIECE(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,5))_" Follow up: "_$$FMTE^XLFDT($PIECE(^AUPNGOAL(APCHX,21,APCHY,11,APCHZ,0),U,6))
DO S^APCHPWH1(X)
End DoDot:3
End DoDot:2
+35 QUIT
End DoDot:1
+36 QUIT
EDUC(P,DATA) ;EP pass back array of all educ topics
+1 ;any topic that begins with ASM or 493
+2 KILL DATA
+3 IF '$GET(P)
QUIT
+4 NEW APCHE,X,E,%,G,A,N,D,I
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(X,A)
+8 IF '$DATA(^TMP($JOB,"A",1))
QUIT
+9 SET %=0
FOR
SET %=$ORDER(^TMP($JOB,"A",%))
IF %'=+%
QUIT
Begin DoDot:1
+10 SET D=$PIECE(^TMP($JOB,"A",%),U,1)
+11 SET I=+$PIECE(^TMP($JOB,"A",%),U,4)
+12 SET N=$PIECE(^AUPNVPED(I,0),U)
+13 IF 'N
QUIT
+14 ;only those with goal stuff
IF $PIECE(^AUPNVPED(I,0),U,14)=""
QUIT
+15 SET APCHE($PIECE(^TMP($JOB,"A",%),U,2),9999999-D)=$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.06)_U_$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.13)_U_$$VAL^XBDIQ1(9000010.16,+$PIECE(^TMP($JOB,"A",%),U,4),.14)
End DoDot:1
+16 SET N=""
FOR
SET N=$ORDER(APCHE(N))
IF N=""
QUIT
SET DATA(N)=(9999999-$ORDER(APCHE(N,0)))_U_APCHE(N,$ORDER(APCHE(N,0)))
+17 KILL APCHE,^TMP($JOB,"A")
+18 QUIT
+19 ;
GOAL(P,DATA) ;EP - pass back array in chronological order by start date and ien
+1 KILL DATA
+2 IF '$GET(P)
QUIT
+3 NEW APCHE,X,E,%,G,A,N,D,I
+4 SET X=0
FOR
SET X=$ORDER(^AUPNGOAL("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNGOAL(X,0))
QUIT
+6 ;not set excluded
IF $PIECE(^AUPNGOAL(X,0),U,1)="N"
QUIT
+7 ;MET
IF $PIECE(^AUPNGOAL(X,0),U,11)="ME"
QUIT
+8 ;deleted
IF $PIECE(^AUPNGOAL(X,0),U,11)="D"
QUIT
+9 ;changed
IF $PIECE(^AUPNGOAL(X,0),U,11)="S"
QUIT
+10 SET DATA(X)=""
End DoDot:1
+11 QUIT
