BHSMU ;IHS/CIA/MGH - Health Summary Utilities ;30-Nov-2015 10:26;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9,12**;March 17, 2006;Build 3
;===================================================================
;Taken from APCHSMU
; IHS/CMI/LAB - utilities for hmr ; [ 09/08/04 10:39 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**8,10,11,12**;JUN 24, 1997
;Patch 2 changed for Code set versioning
;Patch 12 changed to use new API
;
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)
;
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 o f loinc taxonmy
;now get all loinc/taxonomy tests
N J,L
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
...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 "" ;no ien or taxonomy
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 ""
LASTITEM(P,V,T,F) ;EP - return last item V
I $G(F)="" S F="D"
NEW BHSY,%,E,Y K BHSY S %=P_"^LAST "_T_" "_V,E=$$START1^APCLDF(%,"BHSY(")
Q $S(F="D":$P($G(BHSY(1)),"^"),1:$P($G(BHSY(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 ""
PLTAX(P,A,S) ;EP - is DM on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
S S=$G(S)
N T,TAXARR
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)
.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
I $$AICD^BHSUTL S T=+$$CODEN^ICDEX(A,80)
E S T=+$$CODEN^ICDCODE(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)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) 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 "" ;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)_$E($$VAL^XBDIQ1(F,I,.01),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,.01),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 Refused "
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 BHSY,%,LPAP,T S LPAP="",%=P_"^LAST LAB PAP SMEAR",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LPAP=$P(BHSY(1),U)
K BHSY S %=P_"^LAST LAB [BGP PAP SMEAR TAX",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(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 BHSY S %=P_"^LAST DX V76.2",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.S V=$P(BHSY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(1),U)
K BHSY S %=P_"^LAST DX V72.31",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.S V=$P(BHSY(1),U,5) S V=$$PRIMPROV^APCLV(V,"F") I V,$P($G(^DIC(7,V,9999999)),U,3)'="Y" Q
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(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 BHSY S %=P_"^LAST PROCEDURE 91.46",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LPAP>$P(BHSY(1),U)
.S LPAP=$P(BHSY(1),U)
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)
LASTFLU(P,C) ;EP - return last flu shot date
NEW BHSY,%,LFLU,T,E S LFLU="",%=P_"^LAST IMMUNIZATION "_C,E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LFLU=$P(BHSY(1),U)
K BHSY S %=P_"^LAST DX V04.8",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LFLU>$P(BHSY(1),U)
.S LFLU=$P(BHSY(1),U)
K BHSY S %=P_"^LAST DX V06.6",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LFLU>$P(BHSY(1),U)
.S LFLU=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 99.52",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LFLU>$P(BHSY(1),U)
.S LFLU=$P(BHSY(1),U)
K BHSY NEW % F %=1:1 S T=$T(FLUCPTS+%^APCHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
.Q:LFLU>$P(BHSY(1),U)
.S LFLU=$P(BHSY(1),U)
Q $G(LFLU)
LASTBE(P) ;EP
I '$G(P) Q ""
NEW BHSY,LBE,%,E,T,X,Y,V S LBE=""
K BHSY S %=P_"^LAST PROCEDURE 87.64",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LBE=$P(BHSY(1),U)
K BHSY NEW % F %=1:1 S T=$T(BECPTS+%^APCHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
.Q:LBE>$P(BHSY(1),U)
.S LBE=$P(BHSY(1),U)
S (X,Y,V)=0 F S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X D
.S V=$P(^AUPNVRAD(X,0),U,3),V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
.I Y=74280,V>LBE S LBE=V Q
.I Y=74270,V>LBE S LBE=V Q
.I Y=74275,V>LBE S LBE=V Q
Q $G(LBE)
LASTCOLO(P) ;EP
I '$G(P) Q ""
NEW BHSY,LCOLO,%,E,T S LCOLO=""
K BHSY S %=P_"^LAST PROCEDURE 45.43",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LCOLO=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 45.22",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LCOLO>$P(BHSY(1),U)
.S LCOLO=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 45.23",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LCOLO>$P(BHSY(1),U)
.S LCOLO=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 45.25",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) D
.Q:LCOLO>$P(BHSY(1),U)
.S LCOLO=$P(BHSY(1),U)
;K BHSY NEW % F %=1:1 S T=$T(COLOCPTS+%^APCHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
;.Q:LCOLO>$P(BHSY(1),U)
;.S LCOLO=$P(BHSY(1),U)
S T=$O(^ATXAX("B","BGP COLO CPTS",0))
S X=$$CPT^APCHSMU2(P,$P(^DPT(P,0),U,3),DT,T,3)
I X D
.S LCOLO=X
Q $G(LCOLO)
LASTSIG(P) ;EP
I '$G(P) Q ""
NEW BHSY,LSIG,%,E,T S LSIG=""
K BHSY S %=P_"^LAST PROCEDURE 45.24",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)) S LSIG=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 48.23",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY) D
.Q:LSIG>$P(BHSY(1),U)
.S LSIG=$P(BHSY(1),U)
K BHSY NEW % F %=1:1 S T=$T(SIGCPTS+%^APCHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
.Q:LSIG>$P(BHSY(1),U)
.S LSIG=$P(BHSY(1),U)
Q $G(LSIG)
LASTVISI(P) ;EP - get last vision exam (exam,measurments)
I '$G(P) Q ""
NEW D,%
S D=$$LASTITEM(P,"19","EXAM")
S %=$$LASTITEM(P,"07","MEASUREMENT")
I %]D S D=%
S %=$$LASTITEM(P,"08","MEASUREMENT")
I %]D S D=%
Q D
LASTHEAR(P) ;EP
I '$G(P) Q ""
NEW D,%
S D=$$LASTITEM(P,"17","EXAM")
S %=$$LASTITEM(P,"23","EXAM")
I %>D S D=%
S %=$$LASTITEM(P,"24","EXAM")
I %>D S D=%
S %=$$LASTITEM(P,"09","MEASUREMENT")
I %>D S D=%
S %=$$LASTITEM(P,10,"MEASUREMENT")
I %>D S D=%
Q D
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)) ;ien of category passed
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 BHSY,%,E,Y K BHSY S %=P_"^FIRST "_T_" "_V,E=$$START1^APCLDF(%,"BHSY(")
Q $S(F="D":$P($G(BHSY(1)),"^"),1:$P($G(BHSY(1)),"^",2))
;
BHSMU ;IHS/CIA/MGH - Health Summary Utilities ;30-Nov-2015 10:26;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9,12**;March 17, 2006;Build 3
+2 ;===================================================================
+3 ;Taken from APCHSMU
+4 ; IHS/CMI/LAB - utilities for hmr ; [ 09/08/04 10:39 AM ]
+5 ;;2.0;IHS RPMS/PCC Health Summary;**8,10,11,12**;JUN 24, 1997
+6 ;Patch 2 changed for Code set versioning
+7 ;Patch 12 changed to use new API
+8 ;
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 ;
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 o f loinc taxonmy
+1 ;now get all loinc/taxonomy tests
+2 NEW J,L
+3 IF $GET(F)=""
SET F="D"
+4 SET APCHC=""
+5 SET D=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(APCHC)
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(APCHC)
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(APCHC)
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $GET(APCHI)
IF L=APCHI
SET APCHC=(9999999-D)
QUIT
+10 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
+11 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+12 IF '$$LOINC(J,$GET(APCHLT),$GET(APCHL))
QUIT
+13 SET APCHC=(9999999-D)
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT APCHC
LOINC(A,LT,LI) ;
+1 ;no ien or taxonomy
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 ""
LASTITEM(P,V,T,F) ;EP - return last item V
+1 IF $GET(F)=""
SET F="D"
+2 NEW BHSY,%,E,Y
KILL BHSY
SET %=P_"^LAST "_T_" "_V
SET E=$$START1^APCLDF(%,"BHSY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(BHSY(1)),"^"),1:$PIECE($GET(BHSY(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 ""
PLTAX(P,A,S) ;EP - is DM on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 SET S=$GET(S)
+4 NEW T,TAXARR
+5 SET T=$ORDER(^ATXAX("B",A,0))
+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))
Begin DoDot:1
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^ATXAPI(Y,T,9)
QUIT
+10 SET I=1
End DoDot:1
+11 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 IF $$AICD^BHSUTL
SET T=+$$CODEN^ICDEX(A,80)
+6 IF '$TEST
SET T=+$$CODEN^ICDCODE(A,80)
+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))
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXAPI(Y,T,9)
SET I=X
+9 IF F=1
QUIT I
+10 IF F=2
QUIT X
+11 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 ;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)_$EXTRACT($$VAL^XBDIQ1(F,I,.01),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,.01),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 Refused "
+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 BHSY,%,LPAP,T
SET LPAP=""
SET %=P_"^LAST LAB PAP SMEAR"
SET E=$$START1^APCLDF(%,"BHSY(")
+3 IF $DATA(BHSY(1))
SET LPAP=$PIECE(BHSY(1),U)
+4 KILL BHSY
SET %=P_"^LAST LAB [BGP PAP SMEAR TAX"
SET E=$$START1^APCLDF(%,"BHSY(")
+5 IF $DATA(BHSY(1))
Begin DoDot:1
+6 IF LPAP>$PIECE(BHSY(1),U)
QUIT
+7 SET LPAP=$PIECE(BHSY(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 BHSY
SET %=P_"^LAST DX V76.2"
SET E=$$START1^APCLDF(%,"BHSY(")
+20 IF $DATA(BHSY(1))
Begin DoDot:1
+21 SET V=$PIECE(BHSY(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(BHSY(1),U)
QUIT
+23 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+24 KILL BHSY
SET %=P_"^LAST DX V72.31"
SET E=$$START1^APCLDF(%,"BHSY(")
+25 IF $DATA(BHSY(1))
Begin DoDot:1
+26 SET V=$PIECE(BHSY(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(BHSY(1),U)
QUIT
+28 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+29 KILL APCHY
SET %=P_"^LAST DX V72.32"
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 KILL APCHY
SET %=P_"^LAST DX V76.47"
SET E=$$START1^APCLDF(%,"APCHY(")
+35 IF $DATA(APCHY(1))
Begin DoDot:1
+36 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
+37 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+38 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:1
+39 FOR APCHC="795.01","795.02","795.03","795.05","795.06","795.08","795.09"
Begin DoDot:1
+40 KILL APCHY
SET %=P_"^LAST DX "_APCHC
SET E=$$START1^APCLDF(%,"APCHY(")
+41 IF $DATA(APCHY(1))
Begin DoDot:2
+42 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
+43 IF LPAP>$PIECE(APCHY(1),U)
QUIT
+44 SET LPAP=$PIECE(APCHY(1),U)
End DoDot:2
End DoDot:1
+45 KILL BHSY
SET %=P_"^LAST PROCEDURE 91.46"
SET E=$$START1^APCLDF(%,"BHSY(")
+46 IF $DATA(BHSY(1))
Begin DoDot:1
+47 IF LPAP>$PIECE(BHSY(1),U)
QUIT
+48 SET LPAP=$PIECE(BHSY(1),U)
End DoDot:1
+49 SET T=$ORDER(^ATXAX("B","BGP CPT PAP",0))
+50 SET X=$$CPT^APCHSMU2(P,$PIECE(^DPT(P,0),U,3),DT,T,3)
+51 IF X
Begin DoDot:1
+52 IF LPAP>X
QUIT
+53 SET LPAP=X
End DoDot:1
+54 QUIT $GET(LPAP)
LASTFLU(P,C) ;EP - return last flu shot date
+1 NEW BHSY,%,LFLU,T,E
SET LFLU=""
SET %=P_"^LAST IMMUNIZATION "_C
SET E=$$START1^APCLDF(%,"BHSY(")
+2 IF $DATA(BHSY(1))
SET LFLU=$PIECE(BHSY(1),U)
+3 KILL BHSY
SET %=P_"^LAST DX V04.8"
SET E=$$START1^APCLDF(%,"BHSY(")
+4 IF $DATA(BHSY(1))
Begin DoDot:1
+5 IF LFLU>$PIECE(BHSY(1),U)
QUIT
+6 SET LFLU=$PIECE(BHSY(1),U)
End DoDot:1
+7 KILL BHSY
SET %=P_"^LAST DX V06.6"
SET E=$$START1^APCLDF(%,"BHSY(")
+8 IF $DATA(BHSY(1))
Begin DoDot:1
+9 IF LFLU>$PIECE(BHSY(1),U)
QUIT
+10 SET LFLU=$PIECE(BHSY(1),U)
End DoDot:1
+11 KILL BHSY
SET %=P_"^LAST PROCEDURE 99.52"
SET E=$$START1^APCLDF(%,"BHSY(")
+12 IF $DATA(BHSY(1))
Begin DoDot:1
+13 IF LFLU>$PIECE(BHSY(1),U)
QUIT
+14 SET LFLU=$PIECE(BHSY(1),U)
End DoDot:1
+15 KILL BHSY
NEW %
FOR %=1:1
SET T=$TEXT(FLUCPTS+%^APCHSMU1)
IF $PIECE(T,";;",2)=""
QUIT
SET T=$PIECE(T,";;",2)
SET T=$ORDER(^ICPT("B",T,0))
IF T
SET BHSY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
IF BHSY(1)
SET BHSY(1)=9999999-BHSY(1)
Begin DoDot:1
+16 IF LFLU>$PIECE(BHSY(1),U)
QUIT
+17 SET LFLU=$PIECE(BHSY(1),U)
End DoDot:1
+18 QUIT $GET(LFLU)
LASTBE(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BHSY,LBE,%,E,T,X,Y,V
SET LBE=""
+3 KILL BHSY
SET %=P_"^LAST PROCEDURE 87.64"
SET E=$$START1^APCLDF(%,"BHSY(")
+4 IF $DATA(BHSY(1))
SET LBE=$PIECE(BHSY(1),U)
+5 KILL BHSY
NEW %
FOR %=1:1
SET T=$TEXT(BECPTS+%^APCHSMU1)
IF $PIECE(T,";;",2)=""
QUIT
SET T=$PIECE(T,";;",2)
SET T=$ORDER(^ICPT("B",T,0))
IF T
SET BHSY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
IF BHSY(1)
SET BHSY(1)=9999999-BHSY(1)
Begin DoDot:1
+6 IF LBE>$PIECE(BHSY(1),U)
QUIT
+7 SET LBE=$PIECE(BHSY(1),U)
End DoDot:1
+8 SET (X,Y,V)=0
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+10 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+11 IF Y=74280
IF V>LBE
SET LBE=V
QUIT
+12 IF Y=74270
IF V>LBE
SET LBE=V
QUIT
+13 IF Y=74275
IF V>LBE
SET LBE=V
QUIT
End DoDot:1
+14 QUIT $GET(LBE)
LASTCOLO(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BHSY,LCOLO,%,E,T
SET LCOLO=""
+3 KILL BHSY
SET %=P_"^LAST PROCEDURE 45.43"
SET E=$$START1^APCLDF(%,"BHSY(")
+4 IF $DATA(BHSY(1))
SET LCOLO=$PIECE(BHSY(1),U)
+5 KILL BHSY
SET %=P_"^LAST PROCEDURE 45.22"
SET E=$$START1^APCLDF(%,"BHSY(")
+6 IF $DATA(BHSY(1))
Begin DoDot:1
+7 IF LCOLO>$PIECE(BHSY(1),U)
QUIT
+8 SET LCOLO=$PIECE(BHSY(1),U)
End DoDot:1
+9 KILL BHSY
SET %=P_"^LAST PROCEDURE 45.23"
SET E=$$START1^APCLDF(%,"BHSY(")
+10 IF $DATA(BHSY(1))
Begin DoDot:1
+11 IF LCOLO>$PIECE(BHSY(1),U)
QUIT
+12 SET LCOLO=$PIECE(BHSY(1),U)
End DoDot:1
+13 KILL BHSY
SET %=P_"^LAST PROCEDURE 45.25"
SET E=$$START1^APCLDF(%,"BHSY(")
+14 IF $DATA(BHSY(1))
Begin DoDot:1
+15 IF LCOLO>$PIECE(BHSY(1),U)
QUIT
+16 SET LCOLO=$PIECE(BHSY(1),U)
End DoDot:1
+17 ;K BHSY NEW % F %=1:1 S T=$T(COLOCPTS+%^APCHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S BHSY(1)=$O(^AUPNVCPT("AA",P,T,0)) I BHSY(1) S BHSY(1)=9999999-BHSY(1) D
+18 ;.Q:LCOLO>$P(BHSY(1),U)
+19 ;.S LCOLO=$P(BHSY(1),U)
+20 SET T=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+21 SET X=$$CPT^APCHSMU2(P,$PIECE(^DPT(P,0),U,3),DT,T,3)
+22 IF X
Begin DoDot:1
+23 SET LCOLO=X
End DoDot:1
+24 QUIT $GET(LCOLO)
LASTSIG(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BHSY,LSIG,%,E,T
SET LSIG=""
+3 KILL BHSY
SET %=P_"^LAST PROCEDURE 45.24"
SET E=$$START1^APCLDF(%,"BHSY(")
+4 IF $DATA(BHSY(1))
SET LSIG=$PIECE(BHSY(1),U)
+5 KILL BHSY
SET %=P_"^LAST PROCEDURE 48.23"
SET E=$$START1^APCLDF(%,"BHSY(")
+6 IF $DATA(BHSY)
Begin DoDot:1
+7 IF LSIG>$PIECE(BHSY(1),U)
QUIT
+8 SET LSIG=$PIECE(BHSY(1),U)
End DoDot:1
+9 KILL BHSY
NEW %
FOR %=1:1
SET T=$TEXT(SIGCPTS+%^APCHSMU1)
IF $PIECE(T,";;",2)=""
QUIT
SET T=$PIECE(T,";;",2)
SET T=$ORDER(^ICPT("B",T,0))
IF T
SET BHSY(1)=$ORDER(^AUPNVCPT("AA",P,T,0))
IF BHSY(1)
SET BHSY(1)=9999999-BHSY(1)
Begin DoDot:1
+10 IF LSIG>$PIECE(BHSY(1),U)
QUIT
+11 SET LSIG=$PIECE(BHSY(1),U)
End DoDot:1
+12 QUIT $GET(LSIG)
LASTVISI(P) ;EP - get last vision exam (exam,measurments)
+1 IF '$GET(P)
QUIT ""
+2 NEW D,%
+3 SET D=$$LASTITEM(P,"19","EXAM")
+4 SET %=$$LASTITEM(P,"07","MEASUREMENT")
+5 IF %]D
SET D=%
+6 SET %=$$LASTITEM(P,"08","MEASUREMENT")
+7 IF %]D
SET D=%
+8 QUIT D
LASTHEAR(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW D,%
+3 SET D=$$LASTITEM(P,"17","EXAM")
+4 SET %=$$LASTITEM(P,"23","EXAM")
+5 IF %>D
SET D=%
+6 SET %=$$LASTITEM(P,"24","EXAM")
+7 IF %>D
SET D=%
+8 SET %=$$LASTITEM(P,"09","MEASUREMENT")
+9 IF %>D
SET D=%
+10 SET %=$$LASTITEM(P,10,"MEASUREMENT")
+11 IF %>D
SET D=%
+12 QUIT D
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 ;ien of category passed
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 BHSY,%,E,Y
KILL BHSY
SET %=P_"^FIRST "_T_" "_V
SET E=$$START1^APCLDF(%,"BHSY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(BHSY(1)),"^"),1:$PIECE($GET(BHSY(1)),"^",2))
+4 ;
