APCHSMU ; IHS/CMI/LAB - utilities for hmr ;
;;2.0;IHS PCC SUITE;**2,5,7,11,16**;MAY 14, 2009;Build 9
;
D1(D) ;EP - DATE WITH 4 YR
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
DATEAGE(P,Y) ;EP
I '$G(P) Q ""
NEW D
S D=$$DOB^AUPNPAT(P),D=($E(D,1,3)+Y)_$E(D,4,7)
Q D
WRITE ;EP - write out reminder
I $G(APCHSGHR) D Q
.NEW A,B
.S B=""
.S APCHSGHR(1)=$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))
.S APCHSGHR(2)=$G(APCHLAST)
.S APCHSGHR(3)=$$DATE($G(APCHLAST))
.S A=0 F S A=$O(APCHSTEX(A)) Q:A'=+A S B=B_" "_APCHSTEX(A)
.S APCHSGHR(4)=B
.S APCHSGHR(5)=$G(APCHNEXT)
.S APCHSGHR(6)=$P($G(APCHICAR),U,4)
.S APCHSGHR(7)=$P($G(APCHICAR),U,5)
.S APCHSGHR(8)=$P($G(APCHICAR),U,6)
I 'APCHSANY D FIRST Q:$D(APCHSQIT) S APCHSANY=1,APCHSNPG=0
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?26,"LAST",?38,"NEXT",! S APCHSCT=0,APCHSNPG=0
W !,$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))
W ?26,$$DATE(APCHLAST)
W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
S APCHSCT=APCHSCT+1
I '(APCHSCT#2) X APCHSCKP Q:$D(APCHSQIT) W:'APCHSNPG !
K APCHSTEX Q
;
FIRST ;EP
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W ?26,"LAST",?38,"NEXT",!
S APCHSCT=0
Q
;
INAC(X) ;EP - active?
Q $P($G(^APCHSURV(X,0)),"^",3)
;
LASTLAB(P,APCHI,APCHT,APCHL,APCHLT,F) ;EP P is patient, APCHI is ien of lab test, APCHT is IEN of lab taxonomy, APCHL is ien of loinc code, APCHLT is ien of loinc taxonmy
I $G(F)="" S F="D"
S APCHC=""
S D=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(APCHC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(APCHC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(APCHC) D
...Q:'$D(^AUPNVLAB(X,0))
...I $G(APCHI),L=APCHI S APCHC=(9999999-D) Q
...I $G(APCHT),$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(APCHT,21,"B",$P(^AUPNVLAB(X,0),U))) S APCHC=(9999999-D) Q
...;Q ;IHS/CMI/LAB - don't check loinc codes
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,$G(APCHLT),$G(APCHL))
...S APCHC=(9999999-D)
...Q
Q APCHC
LOINC(A,LT,LI) ;
I '$G(LT),'$G(LI) Q ""
I A,LI,A=LI Q 1
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",LT,$D(^ATXAX(LT,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(LT,21,"B",%)) Q 1
Q ""
INP ;EP - called from input transform
I $G(X)="" K X Q
;I X="ONCE" Q
I '(+X) D EN^DDIOL("Must begin with a numeric value.") K X Q
I "MDY"'[$E(X,$L(X)) D EN^DDIOL("Must contain a D for Days, M for Months or Y for Years.") K X Q
Q
SITECRIT(M) ;EP - does the site have override age/sex ranges
;1= YES, 0=NO
I '$G(M) Q 0
I '$D(^APCHSURV(M,11)) Q 0 ;no
NEW G,J,K
S G=0,J=0 F S J=$O(^APCHSURV(M,11,J)) Q:J'=+J!(G) D
.I '$O(^APCHSURV(M,11,J,11,0)) S G="" Q
.S K=0 F S K=$O(^APCHSURV(M,11,J,11,K)) Q:K'=+K!(G) D
..I $P(^APCHSURV(M,11,J,11,K,0),U)]"",$P(^(0),U,3)]"" S G=1
..Q
.Q
Q G
AGESEX(M,P,F) ;EP - is this patient correct sex,age for this reminder
I '$G(F) S F=0
I '$G(P) Q 0
I '$G(M) Q 0
NEW S,A,G,MIN,MAX,J,K
S S=$P(^DPT(P,0),U,2),A=$$FMDIFF^XLFDT(DT,$P(^DPT(P,0),U,3))
S G=""
S J=0 F S J=$O(^APCHSURV(M,11,J)) Q:J'=+J!(G]"") D
.Q:$P(^APCHSURV(M,11,J,0),"^")'=S&($P(^APCHSURV(M,11,J,0),"^")'="B")
.I '$O(^APCHSURV(M,11,J,11,0)) S G="" Q ;no age ranges specified! Use default criteria
.S K=0 F S K=$O(^APCHSURV(M,11,J,11,K)) Q:K'=+K!(G]"") D
..S MIN=$P(^APCHSURV(M,11,J,11,K,0),U),MIN=$$DAYS(MIN)
..Q:A<MIN ;patient is less than minimum days old
..S MAX=$P(^APCHSURV(M,11,J,11,K,0),U,2)
..I MAX="" S G=$$DAYS($P(^APCHSURV(M,11,J,11,K,0),"^",3)) Q ;if no max then it's a hit
..S MAX=$$DAYS(MAX)
..Q:A>MAX ;patient is over the max age
..I F=1 S G=1
..S G=$$DAYS($P(^APCHSURV(M,11,J,11,K,0),"^",3))
..Q
.Q
Q G
;
MINAGE(R,P,F) ;EP - is this patient correct sex,age for this reminder
I '$G(F) S F=0
I '$G(P) Q 0
I '$G(R) Q 0
NEW S,A,G,MIN,MAX,J,K,M
S M=99999999
S S=$P(^DPT(P,0),U,2),A=$$FMDIFF^XLFDT(DT,$P(^DPT(P,0),U,3))
S G=""
S J=0 F S J=$O(^APCHSURV(R,11,J)) Q:J'=+J D
.Q:$P(^APCHSURV(R,11,J,0),"^")'=S&($P(^APCHSURV(R,11,J,0),"^")'="B")
.I '$O(^APCHSURV(R,11,J,11,0)) S G="" Q ;no age ranges specified! Use default criteria
.S K=0 F S K=$O(^APCHSURV(R,11,J,11,K)) Q:K'=+K D
..S MIN=$P(^APCHSURV(R,11,J,11,K,0),U),MIN=$$DAYS(MIN)
..Q:A<MIN
..S MAX=$P(^APCHSURV(R,11,J,11,K,0),U,2)
..I MAX="" S G=$$DAYS($P(^APCHSURV(R,11,J,11,K,0),"^",3)) Q ;if no max then it's a hit
..S MAX=$$DAYS(MAX)
..Q:A>MAX ;patient is over the max age
..I MIN<M S M=MIN
..Q
.Q
I M="" Q M
I M=9999999 Q ""
Q (M\365.25)
LASTITEM(P,V,T,F) ;EP - return last item V
I $G(F)="" S F="D"
NEW APCHY,%,E,Y K APCHY S %=P_"^LAST "_T_" "_V,E=$$START1^APCLDF(%,"APCHY(")
Q $S(F="D":$P($G(APCHY(1)),"^"),F="B":$P($G(APCHY(1)),"^")_"^"_$P($G(APCHY(1)),"^",2),1:$P($G(APCHY(1)),"^",2))
;
OVR(P,I) ;EP - return date^prov^comments
I $G(P)="" Q ""
I $G(I)="" Q ""
I '$D(^AUPNHMRO("AA",I,P)) Q ""
NEW % S %=$O(^AUPNHMRO("AA",I,P,0)),%=$O(^AUPNHMRO("AA",I,P,%,0))
I '$D(^AUPNHMRO(%,0)) Q ""
Q $P(^AUPNHMRO(%,0),U,3)_"^"_$$VAL^XBDIQ1(9000025,%,.04)_"^"_$P(^AUPNHMRO(%,0),U,5)
DAYS(V) ;
I V["Y" Q +V*365.25
I V["M" Q +V*30.5
I V["D" Q +V
Q ""
IPLSNO(P,T,B) ;EP - any problem list entry with a SNOMED in T
Q $$IPLSNO^APCHSMU1(P,T)
PLTAX(P,A,S,B) ;EP - is A CODE IN THIS TAXONOMY ACTIVE on problem list 1 or 0
;IF B=1 THEN COUNT INACTIVE
I $G(P)="" Q ""
I $G(A)="" Q ""
S S=$G(S)
S B=$G(B)
N T S T=$O(^ATXAX("B",A,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)) D
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXAPI(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I 'B Q:$P(^AUPNPROB(X,0),U,12)="I" ;CMI/LAB - added per Susan 5/3/16
.I S]"",$P(^AUPNPROB(X,0),U,12)'=S Q
.S I=1
Q I
PLCODE(P,A,F) ;EP
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(F)="" S F=1
N T
S T=+$$CODEABA^ICDEX(A,80)
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)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I Y=T S I=X
I F=1 Q I
I F=2 Q X
Q ""
REF(P,F,I,D,T) ;EP - dm item refused?
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 ""
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)_$E($$VAL^XBDIQ1(F,I,$$FFD(F)),1,(44-$L($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(Y))_"^"_Y
I D]"",Y<D Q "" ;REFUSED BEFORE DATE OF THE LAST
I T="I" Q Y ;quit on internal form of date
Q $$TYPEREF(N)_$E($$VAL^XBDIQ1(F,I,$$FFD(F)),1,(44-$L($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(Y)_"^"_Y
TYPEREF(N) ;EP
NEW % S %=$P(^AUPNPREF(N,0),U,7)
I %="R"!(%="") Q "Patient Declined "
I %="N" Q "Not Medically Indicated "
I %="F" Q "No Response to F/U "
I %="U" Q "Unable to Screen "
Q $$VAL^XBDIQ1(9000022,N,.07)
LASTPAP(P) ;EP - return last pap date
I $$SEX^AUPNPAT(P)'="F" Q ""
NEW APCHY,%,LPAP,T S LPAP="",%=P_"^LAST LAB PAP SMEAR",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) S LPAP=$P(APCHY(1),U)
K APCHY S %=P_"^LAST LAB [BGP PAP SMEAR TAX",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
I $$VERSION^XPDUTL("BW")>2 D
.S X=$P($$WHAPI^BWVPAT1(P,$O(^BWVPDT("B","PAP SMEAR",0))),U)
.I X D
..Q:LPAP>X
..S LPAP=X
I $$VERSION^XPDUTL("BW")<3 D
.S X="" 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
K APCHY S %=P_"^LAST DX V76.2",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.S V=$P(APCHY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
K APCHY S %=P_"^LAST DX V72.32",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.S V=$P(APCHY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
K APCHY S %=P_"^LAST DX V76.47",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.S V=$P(APCHY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
.Q:LPAP>$P(APCHY(1),U)
.S LPAP=$P(APCHY(1),U)
F APCHC="795.01","795.02","795.03","795.05","795.06","795.08","795.09" D
.K APCHY S %=P_"^LAST DX "_APCHC,E=$$START1^APCLDF(%,"APCHY(")
.I $D(APCHY(1)) D
..S V=$P(APCHY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
..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)
S T=$O(^ATXAX("B","BGP CPT PAP",0))
S X=$$CPT^APCHSMU2(P,$P(^DPT(P,0),U,3),DT,T,3)
I X D
.Q:LPAP>X
.S LPAP=X
Q $G(LPAP)
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
I '$G(P) Q ""
I $G(C)="" Q ""
I $G(F)="" S F=""
S C=$O(^AUTTHF("B",C,0))
I '$G(C) Q ""
NEW H,D,O S H=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNVHF("AA",P,H))
. S D=$O(^AUPNVHF("AA",P,H,""))
. Q:'D
. S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
. Q
S D=$O(O(0))
I D="" Q D
I F="N" Q $$VAL^XBDIQ1(9000010.23,O(D),.01)
I F="S" Q $P($G(^AUPNVHF(O(D),0)),U,6)
I F="B" Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
Q 9999999-D
;
FRSTITEM(P,V,T,F) ;EP - return last item V
I $G(F)="" S F="D"
NEW APCHY,%,E,Y K APCHY S %=P_"^FIRST "_T_" "_V,E=$$START1^APCLDF(%,"APCHY(")
Q $S(F="D":$P($G(APCHY(1)),"^"),1:$P($G(APCHY(1)),"^",2))
;
FFD(%) ;EP
I '$G(%) Q .01
NEW X,Y
;S X=$P(^DIC(%,0),U,1)
S X=0,Y="" F S X=$O(^AUTTREFT(X)) Q:X'=+X I $P(^AUTTREFT(X,0),U,2)=% S Y=X
I 'Y Q .01
Q $S($P($G(^AUTTREFT(Y,0)),U,3)]"":$P(^AUTTREFT(Y,0),U,3),1:.01)
;
GVHMR(P,I) ;PEP - can be called by any application
;Input: P - Patient DFN
; I - ien of health maintenance reminder from HEALTH SUMMARY MAINT ITEM file
;Output: Name of reminder^date of last (internal)^date of last (external)^NEXT column value of the HMR as displayed on the health summary^internal of next^visit ien (if available)^file found in^ien of file found in
;
I '$G(P) Q "" ;not a valid patient
I '$D(^AUPNPAT(P)) Q ""
I '$D(^DPT(P)) Q ""
I '$G(I) Q "" ;not a valid HMR ien
I '$D(^APCHSURV(I)) Q "" ;not a valid HMR ien
NEW APCHSGHR,D,R,APCHSDOB,APCHSEX,APCHSANY,APCHSITM,APCHSTEX,APCHSURX,APCHICAR
NEW APCHSTEX,APCHOVR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX
K APCHSGHR
S APCHSGHR=1,R=""
I $P(^APCHSURV(I,0),U,3)="D" Q "" ;deleted HMR
I '$P(^APCHSURV(I,0),U,6) Q "" ;not officially maintained by IHS
I $P(^APCHSURV(I,0),U,7)'="R" ;not a reminder
S D=$P(^APCHSURV(I,0),U,2)
I D="" Q "" ;no program id
S APCHSPAT=P
S APCHSITI=I
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S X1=DT,X2=APCHSDOB D ^%DTC S APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
;
S (APCHSANY,APCHSITM)=0
K APCHSTEX
S APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
D @($P(D,";")_U_$P(D,";",2))
;W !!,APCHSGHR
I $O(APCHSGHR(0))="" Q ""
F D=1:1:8 I $D(APCHSGHR(D)) S $P(R,U,D)=$$TRIM^APCHS11C($G(APCHSGHR(D)))
Q R
;
GVTP(P,I,C,APCHRVAL) ;PEP - can be called by any application
;Input: P - Patient DFN
; I - ien of health maintenance reminder from HEALTH SUMMARY MAINT ITEM file (MUST BE A TYPE OF BEST PRACTICE PROMPT - .07 FIELD VALUE = T)
; C - width of output text, default is 80
;Output: ARRAY NAMED IN APCHRVAL Format:
; APCHRVAL(0)="1^NAME OF BEST PRACTICE PROMPT (.01 value of health summary maint item file)
; APCHRVAL(1-n) = array of Best Practice Prompt text formatted to C width
; APCHRVAL(0)="0^message" if no Best Practice Prompt value
;
K APCHRVAL
I '$G(P) S APCHRVAL(0)="0^No Patient identified" Q ;not a valid patient
I '$D(^AUPNPAT(P)) S APCHRVAL(0)="0^No Patient identified" Q
I '$D(^DPT(P)) S APCHRVAL(0)="0^No Patient identified" Q
I '$G(I) S APCHRVAL(0)="0^No Best Practice Prompt identified" Q ;not a valid HMR ien
I '$D(^APCHSURV(I)) S APCHRVAL(0)="0^Not a Best Practice Prompt" Q ;not a valid HMR ien
I $P(^APCHSURV(I,0),U,7)'="T" S APCHRVAL(0)="0^Not a Best Practice Prompt" Q
I $P(^APCHSURV(I,0),U,3)="D" S APCHRVAL(0)="0^Not a valid Best Practice Prompt" Q ;deleted HMR
I '$P(^APCHSURV(I,0),U,6) S APCHRVAL(0)="0^Not a valid Best Practice Prompt" Q ;not officially maintained by IHS
S D=$P(^APCHSURV(I,0),U,2)
I D="" Q "" ;no program id
NEW APCHSGHR,D,R,APCHSDOB,APCHSEX,APCHSANY,APCHSITM,APCHSTEX,APCHSURX,APCHICAR,APCHCOLW
NEW APCHSTEX,APCHOVR,APCHLAST,APCHNEXT,APCHSBWR,X,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX
S APCHCOLW=$G(C)
I C'>5 S APCHCOLW=80
K APCHSGHR
S APCHSGHR=1,R=""
S D=$P(^APCHSURV(I,0),U,2)
I D="" S APCHRVAL(0)="0^Not a valid Best Practice Prompt" Q
S APCHSPAT=P
S APCHSITI=I
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S X1=DT,X2=APCHSDOB D ^%DTC S APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
;
S (APCHSANY,APCHSITM)=0
K APCHSTEX
S APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
D @($P(D,";")_U_$P(D,";",2))
Q
;
REFUSAL(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
;
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,81,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..Q:'$$ICD^ATXAPI(I,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
APCHSMU ; IHS/CMI/LAB - utilities for hmr ;
+1 ;;2.0;IHS PCC SUITE;**2,5,7,11,16**;MAY 14, 2009;Build 9
+2 ;
D1(D) ;EP - DATE WITH 4 YR
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
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)
+3 ;
DATEAGE(P,Y) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW D
+3 SET D=$$DOB^AUPNPAT(P)
SET D=($EXTRACT(D,1,3)+Y)_$EXTRACT(D,4,7)
+4 QUIT D
WRITE ;EP - write out reminder
+1 IF $GET(APCHSGHR)
Begin DoDot:1
+2 NEW A,B
+3 SET B=""
+4 SET APCHSGHR(1)=$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))
+5 SET APCHSGHR(2)=$GET(APCHLAST)
+6 SET APCHSGHR(3)=$$DATE($GET(APCHLAST))
+7 SET A=0
FOR
SET A=$ORDER(APCHSTEX(A))
IF A'=+A
QUIT
SET B=B_" "_APCHSTEX(A)
+8 SET APCHSGHR(4)=B
+9 SET APCHSGHR(5)=$GET(APCHNEXT)
+10 SET APCHSGHR(6)=$PIECE($GET(APCHICAR),U,4)
+11 SET APCHSGHR(7)=$PIECE($GET(APCHICAR),U,5)
+12 SET APCHSGHR(8)=$PIECE($GET(APCHICAR),U,6)
End DoDot:1
QUIT
+13 IF 'APCHSANY
DO FIRST
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
SET APCHSNPG=0
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT",!
SET APCHSCT=0
SET APCHSNPG=0
+16 WRITE !,$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))
+17 WRITE ?26,$$DATE(APCHLAST)
+18 WRITE ?36,APCHSTEX(1)
FOR APCHSL=2:1
IF '$DATA(APCHSTEX(APCHSL))
QUIT
WRITE !,?36,APCHSTEX(APCHSL)
+19 SET APCHSCT=APCHSCT+1
+20 IF '(APCHSCT#2)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
+21 KILL APCHSTEX
QUIT
+22 ;
FIRST ;EP
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+2 WRITE ?26,"LAST",?38,"NEXT",!
+3 SET APCHSCT=0
+4 QUIT
+5 ;
INAC(X) ;EP - active?
+1 QUIT $PIECE($GET(^APCHSURV(X,0)),"^",3)
+2 ;
LASTLAB(P,APCHI,APCHT,APCHL,APCHLT,F) ;EP P is patient, APCHI is ien of lab test, APCHT is IEN of lab taxonomy, APCHL is ien of loinc code, APCHLT is ien of loinc taxonmy
+1 IF $GET(F)=""
SET F="D"
+2 SET APCHC=""
+3 SET D=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(APCHC)
QUIT
Begin DoDot:1
+4 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(APCHC)
QUIT
Begin DoDot:2
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(APCHC)
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+7 IF $GET(APCHI)
IF L=APCHI
SET APCHC=(9999999-D)
QUIT
+8 IF $GET(APCHT)
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(APCHT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET APCHC=(9999999-D)
QUIT
+9 ;Q ;IHS/CMI/LAB - don't check loinc codes
+10 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J,$GET(APCHLT),$GET(APCHL))
QUIT
+12 SET APCHC=(9999999-D)
+13 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT APCHC
LOINC(A,LT,LI) ;
+1 IF '$GET(LT)
IF '$GET(LI)
QUIT ""
+2 IF A
IF LI
IF A=LI
QUIT 1
+3 NEW %
+4 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+5 IF %]""
IF LT
IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+6 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+7 IF $DATA(^ATXAX(LT,21,"B",%))
QUIT 1
+8 QUIT ""
INP ;EP - called from input transform
+1 IF $GET(X)=""
KILL X
QUIT
+2 ;I X="ONCE" Q
+3 IF '(+X)
DO EN^DDIOL("Must begin with a numeric value.")
KILL X
QUIT
+4 IF "MDY"'[$EXTRACT(X,$LENGTH(X))
DO EN^DDIOL("Must contain a D for Days, M for Months or Y for Years.")
KILL X
QUIT
+5 QUIT
SITECRIT(M) ;EP - does the site have override age/sex ranges
+1 ;1= YES, 0=NO
+2 IF '$GET(M)
QUIT 0
+3 ;no
IF '$DATA(^APCHSURV(M,11))
QUIT 0
+4 NEW G,J,K
+5 SET G=0
SET J=0
FOR
SET J=$ORDER(^APCHSURV(M,11,J))
IF J'=+J!(G)
QUIT
Begin DoDot:1
+6 IF '$ORDER(^APCHSURV(M,11,J,11,0))
SET G=""
QUIT
+7 SET K=0
FOR
SET K=$ORDER(^APCHSURV(M,11,J,11,K))
IF K'=+K!(G)
QUIT
Begin DoDot:2
+8 IF $PIECE(^APCHSURV(M,11,J,11,K,0),U)]""
IF $PIECE(^(0),U,3)]""
SET G=1
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT G
AGESEX(M,P,F) ;EP - is this patient correct sex,age for this reminder
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(M)
QUIT 0
+4 NEW S,A,G,MIN,MAX,J,K
+5 SET S=$PIECE(^DPT(P,0),U,2)
SET A=$$FMDIFF^XLFDT(DT,$PIECE(^DPT(P,0),U,3))
+6 SET G=""
+7 SET J=0
FOR
SET J=$ORDER(^APCHSURV(M,11,J))
IF J'=+J!(G]"")
QUIT
Begin DoDot:1
+8 IF $PIECE(^APCHSURV(M,11,J,0),"^")'=S&($PIECE(^APCHSURV(M,11,J,0),"^")'="B")
QUIT
+9 ;no age ranges specified! Use default criteria
IF '$ORDER(^APCHSURV(M,11,J,11,0))
SET G=""
QUIT
+10 SET K=0
FOR
SET K=$ORDER(^APCHSURV(M,11,J,11,K))
IF K'=+K!(G]"")
QUIT
Begin DoDot:2
+11 SET MIN=$PIECE(^APCHSURV(M,11,J,11,K,0),U)
SET MIN=$$DAYS(MIN)
+12 ;patient is less than minimum days old
IF A<MIN
QUIT
+13 SET MAX=$PIECE(^APCHSURV(M,11,J,11,K,0),U,2)
+14 ;if no max then it's a hit
IF MAX=""
SET G=$$DAYS($PIECE(^APCHSURV(M,11,J,11,K,0),"^",3))
QUIT
+15 SET MAX=$$DAYS(MAX)
+16 ;patient is over the max age
IF A>MAX
QUIT
+17 IF F=1
SET G=1
+18 SET G=$$DAYS($PIECE(^APCHSURV(M,11,J,11,K,0),"^",3))
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT G
+22 ;
MINAGE(R,P,F) ;EP - is this patient correct sex,age for this reminder
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(R)
QUIT 0
+4 NEW S,A,G,MIN,MAX,J,K,M
+5 SET M=99999999
+6 SET S=$PIECE(^DPT(P,0),U,2)
SET A=$$FMDIFF^XLFDT(DT,$PIECE(^DPT(P,0),U,3))
+7 SET G=""
+8 SET J=0
FOR
SET J=$ORDER(^APCHSURV(R,11,J))
IF J'=+J
QUIT
Begin DoDot:1
+9 IF $PIECE(^APCHSURV(R,11,J,0),"^")'=S&($PIECE(^APCHSURV(R,11,J,0),"^")'="B")
QUIT
+10 ;no age ranges specified! Use default criteria
IF '$ORDER(^APCHSURV(R,11,J,11,0))
SET G=""
QUIT
+11 SET K=0
FOR
SET K=$ORDER(^APCHSURV(R,11,J,11,K))
IF K'=+K
QUIT
Begin DoDot:2
+12 SET MIN=$PIECE(^APCHSURV(R,11,J,11,K,0),U)
SET MIN=$$DAYS(MIN)
+13 IF A<MIN
QUIT
+14 SET MAX=$PIECE(^APCHSURV(R,11,J,11,K,0),U,2)
+15 ;if no max then it's a hit
IF MAX=""
SET G=$$DAYS($PIECE(^APCHSURV(R,11,J,11,K,0),"^",3))
QUIT
+16 SET MAX=$$DAYS(MAX)
+17 ;patient is over the max age
IF A>MAX
QUIT
+18 IF MIN<M
SET M=MIN
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 IF M=""
QUIT M
+22 IF M=9999999
QUIT ""
+23 QUIT (M\365.25)
LASTITEM(P,V,T,F) ;EP - return last item V
+1 IF $GET(F)=""
SET F="D"
+2 NEW APCHY,%,E,Y
KILL APCHY
SET %=P_"^LAST "_T_" "_V
SET E=$$START1^APCLDF(%,"APCHY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(APCHY(1)),"^"),F="B":$PIECE($GET(APCHY(1)),"^")_"^"_$PIECE($GET(APCHY(1)),"^",2),1:$PIECE($GET(APCHY(1)),"^",2))
+4 ;
OVR(P,I) ;EP - return date^prov^comments
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(I)=""
QUIT ""
+3 IF '$DATA(^AUPNHMRO("AA",I,P))
QUIT ""
+4 NEW %
SET %=$ORDER(^AUPNHMRO("AA",I,P,0))
SET %=$ORDER(^AUPNHMRO("AA",I,P,%,0))
+5 IF '$DATA(^AUPNHMRO(%,0))
QUIT ""
+6 QUIT $PIECE(^AUPNHMRO(%,0),U,3)_"^"_$$VAL^XBDIQ1(9000025,%,.04)_"^"_$PIECE(^AUPNHMRO(%,0),U,5)
DAYS(V) ;
+1 IF V["Y"
QUIT +V*365.25
+2 IF V["M"
QUIT +V*30.5
+3 IF V["D"
QUIT +V
+4 QUIT ""
IPLSNO(P,T,B) ;EP - any problem list entry with a SNOMED in T
+1 QUIT $$IPLSNO^APCHSMU1(P,T)
PLTAX(P,A,S,B) ;EP - is A CODE IN THIS TAXONOMY ACTIVE on problem list 1 or 0
+1 ;IF B=1 THEN COUNT INACTIVE
+2 IF $GET(P)=""
QUIT ""
+3 IF $GET(A)=""
QUIT ""
+4 SET S=$GET(S)
+5 SET B=$GET(B)
+6 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+7 IF 'T
QUIT ""
+8 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))
Begin DoDot:1
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 IF '$$ICD^ATXAPI(Y,T,9)
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+12 ;CMI/LAB - added per Susan 5/3/16
IF 'B
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+13 IF S]""
IF $PIECE(^AUPNPROB(X,0),U,12)'=S
QUIT
+14 SET I=1
End DoDot:1
+15 QUIT I
PLCODE(P,A,F) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(F)=""
SET F=1
+4 NEW T
+5 SET T=+$$CODEABA^ICDEX(A,80)
+6 IF 'T
QUIT ""
+7 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))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF Y=T
SET I=X
+8 IF F=1
QUIT I
+9 IF F=2
QUIT X
+10 QUIT ""
REF(P,F,I,D,T) ;EP - dm item refused?
+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 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)_$EXTRACT($$VAL^XBDIQ1(F,I,$$FFD(F)),1,(44-$LENGTH($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(Y))_"^"_Y
+11 ;REFUSED BEFORE DATE OF THE LAST
IF D]""
IF Y<D
QUIT ""
+12 ;quit on internal form of date
IF T="I"
QUIT Y
+13 QUIT $$TYPEREF(N)_$EXTRACT($$VAL^XBDIQ1(F,I,$$FFD(F)),1,(44-$LENGTH($$TYPEREF(N))))_"^on "_$$FMTE^XLFDT(Y)_"^"_Y
TYPEREF(N) ;EP
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Patient Declined "
+3 IF %="N"
QUIT "Not Medically Indicated "
+4 IF %="F"
QUIT "No Response to F/U "
+5 IF %="U"
QUIT "Unable to Screen "
+6 QUIT $$VAL^XBDIQ1(9000022,N,.07)
LASTPAP(P) ;EP - return last pap date
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT ""
+2 NEW APCHY,%,LPAP,T
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 KILL APCHY
SET %=P_"^LAST LAB [BGP PAP SMEAR TAX"
SET E=$$START1^APCLDF(%,"APCHY(")
+5 IF $DATA(APCHY(1))
Begin DoDot:1
+6 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+7 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+8 IF $$VERSION^XPDUTL("BW")>2
Begin DoDot:1
+9 SET X=$PIECE($$WHAPI^BWVPAT1(P,$ORDER(^BWVPDT("B","PAP SMEAR",0))),U)
+10 IF X
Begin DoDot:2
+11 IF LPAP>X
QUIT
+12 SET LPAP=X
End DoDot:2
End DoDot:1
+13 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+14 SET X=""
SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+15 IF T
SET X=$$WH^APCHSMU2(P,$$DOB^AUPNPAT(P),DT,T,3)
+16 IF X]""
Begin DoDot:2
+17 IF LPAP>X
QUIT
+18 SET LPAP=X
End DoDot:2
End DoDot:1
+19 KILL APCHY
SET %=P_"^LAST DX V76.2"
SET E=$$START1^APCLDF(%,"APCHY(")
+20 IF $DATA(APCHY(1))
Begin DoDot:1
+21 SET V=$PIECE(APCHY(1),U,5)
SET V=$$PRIMPROV^APCLV(V,"F")
IF V
IF $PIECE($GET(^DIC(7,V,9999999)),U,3)'="Y"
QUIT
+22 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+23 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+24 KILL APCHY
SET %=P_"^LAST DX V72.32"
SET E=$$START1^APCLDF(%,"APCHY(")
+25 IF $DATA(APCHY(1))
Begin DoDot:1
+26 SET V=$PIECE(APCHY(1),U,5)
SET V=$$PRIMPROV^APCLV(V,"F")
IF V
IF $PIECE($GET(^DIC(7,V,9999999)),U,3)'="Y"
QUIT
+27 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+28 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+29 KILL APCHY
SET %=P_"^LAST DX V76.47"
SET E=$$START1^APCLDF(%,"APCHY(")
+30 IF $DATA(APCHY(1))
Begin DoDot:1
+31 SET V=$PIECE(APCHY(1),U,5)
SET V=$$PRIMPROV^APCLV(V,"F")
IF V
IF $PIECE($GET(^DIC(7,V,9999999)),U,3)'="Y"
QUIT
+32 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+33 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+34 FOR APCHC="795.01","795.02","795.03","795.05","795.06","795.08","795.09"
Begin DoDot:1
+35 KILL APCHY
SET %=P_"^LAST DX "_APCHC
SET E=$$START1^APCLDF(%,"APCHY(")
+36 IF $DATA(APCHY(1))
Begin DoDot:2
+37 SET V=$PIECE(APCHY(1),U,5)
SET V=$$PRIMPROV^APCLV(V,"F")
IF V
IF $PIECE($GET(^DIC(7,V,9999999)),U,3)'="Y"
QUIT
+38 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+39 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:2
End DoDot:1
+40 KILL APCHY
SET %=P_"^LAST PROCEDURE 91.46"
SET E=$$START1^APCLDF(%,"APCHY(")
+41 IF $DATA(APCHY(1))
Begin DoDot:1
+42 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+43 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+44 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
+45 SET X=$$CPT^APCHSMU2(P,$PIECE(^DPT(P,0),U,3),DT,T,3)
+46 IF X
Begin DoDot:1
+47 IF LPAP>X
QUIT
+48 SET LPAP=X
End DoDot:1
+49 QUIT $GET(LPAP)
LASTHF(P,C,F) ;EP - get last factor in category C for patient P
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(C)=""
QUIT ""
+3 IF $GET(F)=""
SET F=""
+4 SET C=$ORDER(^AUTTHF("B",C,0))
+5 IF '$GET(C)
QUIT ""
+6 NEW H,D,O
SET H=0
KILL O
+7 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+9 SET D=$ORDER(^AUPNVHF("AA",P,H,""))
+10 IF 'D
QUIT
+11 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
+12 QUIT
End DoDot:1
+13 SET D=$ORDER(O(0))
+14 IF D=""
QUIT D
+15 IF F="N"
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)
+16 IF F="S"
QUIT $PIECE($GET(^AUPNVHF(O(D),0)),U,6)
+17 IF F="B"
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
+18 QUIT 9999999-D
+19 ;
FRSTITEM(P,V,T,F) ;EP - return last item V
+1 IF $GET(F)=""
SET F="D"
+2 NEW APCHY,%,E,Y
KILL APCHY
SET %=P_"^FIRST "_T_" "_V
SET E=$$START1^APCLDF(%,"APCHY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(APCHY(1)),"^"),1:$PIECE($GET(APCHY(1)),"^",2))
+4 ;
FFD(%) ;EP
+1 IF '$GET(%)
QUIT .01
+2 NEW X,Y
+3 ;S X=$P(^DIC(%,0),U,1)
+4 SET X=0
SET Y=""
FOR
SET X=$ORDER(^AUTTREFT(X))
IF X'=+X
QUIT
IF $PIECE(^AUTTREFT(X,0),U,2)=%
SET Y=X
+5 IF 'Y
QUIT .01
+6 QUIT $SELECT($PIECE($GET(^AUTTREFT(Y,0)),U,3)]"":$PIECE(^AUTTREFT(Y,0),U,3),1:.01)
+7 ;
GVHMR(P,I) ;PEP - can be called by any application
+1 ;Input: P - Patient DFN
+2 ; I - ien of health maintenance reminder from HEALTH SUMMARY MAINT ITEM file
+3 ;Output: Name of reminder^date of last (internal)^date of last (external)^NEXT column value of the HMR as displayed on the health summary^internal of next^visit ien (if available)^file found in^ien of file found in
+4 ;
+5 ;not a valid patient
IF '$GET(P)
QUIT ""
+6 IF '$DATA(^AUPNPAT(P))
QUIT ""
+7 IF '$DATA(^DPT(P))
QUIT ""
+8 ;not a valid HMR ien
IF '$GET(I)
QUIT ""
+9 ;not a valid HMR ien
IF '$DATA(^APCHSURV(I))
QUIT ""
+10 NEW APCHSGHR,D,R,APCHSDOB,APCHSEX,APCHSANY,APCHSITM,APCHSTEX,APCHSURX,APCHICAR
+11 NEW APCHSTEX,APCHOVR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX
+12 KILL APCHSGHR
+13 SET APCHSGHR=1
SET R=""
+14 ;deleted HMR
IF $PIECE(^APCHSURV(I,0),U,3)="D"
QUIT ""
+15 ;not officially maintained by IHS
IF '$PIECE(^APCHSURV(I,0),U,6)
QUIT ""
+16 ;not a reminder
IF $PIECE(^APCHSURV(I,0),U,7)'="R"
+17 SET D=$PIECE(^APCHSURV(I,0),U,2)
+18 ;no program id
IF D=""
QUIT ""
+19 SET APCHSPAT=P
+20 SET APCHSITI=I
+21 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+22 SET X1=DT
SET X2=APCHSDOB
DO ^%DTC
SET APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
+23 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+24 ;
+25 SET (APCHSANY,APCHSITM)=0
+26 KILL APCHSTEX
+27 SET APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
+28 DO @($PIECE(D,";")_U_$PIECE(D,";",2))
+29 ;W !!,APCHSGHR
+30 IF $ORDER(APCHSGHR(0))=""
QUIT ""
+31 FOR D=1:1:8
IF $DATA(APCHSGHR(D))
SET $PIECE(R,U,D)=$$TRIM^APCHS11C($GET(APCHSGHR(D)))
+32 QUIT R
+33 ;
GVTP(P,I,C,APCHRVAL) ;PEP - can be called by any application
+1 ;Input: P - Patient DFN
+2 ; I - ien of health maintenance reminder from HEALTH SUMMARY MAINT ITEM file (MUST BE A TYPE OF BEST PRACTICE PROMPT - .07 FIELD VALUE = T)
+3 ; C - width of output text, default is 80
+4 ;Output: ARRAY NAMED IN APCHRVAL Format:
+5 ; APCHRVAL(0)="1^NAME OF BEST PRACTICE PROMPT (.01 value of health summary maint item file)
+6 ; APCHRVAL(1-n) = array of Best Practice Prompt text formatted to C width
+7 ; APCHRVAL(0)="0^message" if no Best Practice Prompt value
+8 ;
+9 KILL APCHRVAL
+10 ;not a valid patient
IF '$GET(P)
SET APCHRVAL(0)="0^No Patient identified"
QUIT
+11 IF '$DATA(^AUPNPAT(P))
SET APCHRVAL(0)="0^No Patient identified"
QUIT
+12 IF '$DATA(^DPT(P))
SET APCHRVAL(0)="0^No Patient identified"
QUIT
+13 ;not a valid HMR ien
IF '$GET(I)
SET APCHRVAL(0)="0^No Best Practice Prompt identified"
QUIT
+14 ;not a valid HMR ien
IF '$DATA(^APCHSURV(I))
SET APCHRVAL(0)="0^Not a Best Practice Prompt"
QUIT
+15 IF $PIECE(^APCHSURV(I,0),U,7)'="T"
SET APCHRVAL(0)="0^Not a Best Practice Prompt"
QUIT
+16 ;deleted HMR
IF $PIECE(^APCHSURV(I,0),U,3)="D"
SET APCHRVAL(0)="0^Not a valid Best Practice Prompt"
QUIT
+17 ;not officially maintained by IHS
IF '$PIECE(^APCHSURV(I,0),U,6)
SET APCHRVAL(0)="0^Not a valid Best Practice Prompt"
QUIT
+18 SET D=$PIECE(^APCHSURV(I,0),U,2)
+19 ;no program id
IF D=""
QUIT ""
+20 NEW APCHSGHR,D,R,APCHSDOB,APCHSEX,APCHSANY,APCHSITM,APCHSTEX,APCHSURX,APCHICAR,APCHCOLW
+21 NEW APCHSTEX,APCHOVR,APCHLAST,APCHNEXT,APCHSBWR,X,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX
+22 SET APCHCOLW=$GET(C)
+23 IF C'>5
SET APCHCOLW=80
+24 KILL APCHSGHR
+25 SET APCHSGHR=1
SET R=""
+26 SET D=$PIECE(^APCHSURV(I,0),U,2)
+27 IF D=""
SET APCHRVAL(0)="0^Not a valid Best Practice Prompt"
QUIT
+28 SET APCHSPAT=P
+29 SET APCHSITI=I
+30 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+31 SET X1=DT
SET X2=APCHSDOB
DO ^%DTC
SET APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
+32 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+33 ;
+34 SET (APCHSANY,APCHSITM)=0
+35 KILL APCHSTEX
+36 SET APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
+37 DO @($PIECE(D,";")_U_$PIECE(D,";",2))
+38 QUIT
+39 ;
REFUSAL(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
+9 QUIT G
+10 ;
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,81,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 IF '$$ICD^ATXAPI(I,T,1)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
