BDMSMU ; IHS/CMI/LAB - utilities for hmr ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9,10**;JUN 14, 2007;Build 12
;
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(BDMSGHR) D Q
.NEW A,B
.S B=""
.S BDMSGHR(1)=$S($P(^BDMSURV(BDMSITI,0),U,4)]"":$P(^BDMSURV(BDMSITI,0),U,4),1:$P(^BDMSURV(BDMSITI,0),U))
.S BDMSGHR(2)=$G(BDMLAST)
.S BDMSGHR(3)=$$DATE($G(BDMLAST))
.S A=0 F S A=$O(BDMSTEX(A)) Q:A'=+A S B=B_" "_BDMSTEX(A)
.S BDMSGHR(4)=B
.S BDMSGHR(5)=$G(BDMNEXT)
.S BDMSGHR(6)=$P($G(BDMICAR),U,4)
.S BDMSGHR(7)=$P($G(BDMICAR),U,5)
.S BDMSGHR(8)=$P($G(BDMICAR),U,6)
I 'BDMSANY D FIRST Q:$D(BDMSQIT) S BDMSANY=1,BDMSNPG=0
X BDMSCKP Q:$D(BDMSQIT)
I BDMSNPG W ?26,"LAST",?38,"NEXT",! S BDMSCT=0,BDMSNPG=0
W !,$S($P(^BDMSURV(BDMSITI,0),U,4)]"":$P(^BDMSURV(BDMSITI,0),U,4),1:$P(^BDMSURV(BDMSITI,0),U))
W ?26,$$DATE(BDMLAST)
W ?36,BDMSTEX(1) F BDMSL=2:1 Q:'$D(BDMSTEX(BDMSL)) W !,?36,BDMSTEX(BDMSL)
S BDMSCT=BDMSCT+1
I '(BDMSCT#2) X BDMSCKP Q:$D(BDMSQIT) W:'BDMSNPG !
K BDMSTEX Q
;
FIRST ;EP
X BDMSCKP Q:$D(BDMSQIT) X:'BDMSNPG BDMSBRK
W ?26,"LAST",?38,"NEXT",!
S BDMSCT=0
Q
;
INAC(X) ;EP - active?
Q $P($G(^BDMSURV(X,0)),"^",3)
;
LASTLAB(P,BDMI,BDMT,BDML,BDMLT,F) ;EP P is patient, BDMI is ien of lab test, BDMT is IEN of lab taxonomy, BDML is ien of loinc code, BDMLT is ien o f loinc taxonmy
I $G(F)="" S F="D"
S BDMC=""
S D=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(BDMC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BDMC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BDMC) D
...Q:'$D(^AUPNVLAB(X,0))
...I $G(BDMI),L=BDMI S BDMC=(9999999-D) Q
...I $G(BDMT),$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMT,21,"B",$P(^AUPNVLAB(X,0),U))) S BDMC=(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(BDMLT),$G(BDML))
...S BDMC=(9999999-D)
...Q
Q BDMC
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
LASTITEM(P,V,T,F) ;EP - return last item V
I $G(F)="" S F="D"
NEW BDMY,%,E,Y K BDMY S %=P_"^LAST "_T_" "_V,E=$$START1^APCLDF(%,"BDMY(")
Q $S(F="D":$P($G(BDMY(1)),"^"),F="B":$P($G(BDMY(1)),"^")_"^"_$P($G(BDMY(1)),"^",2),1:$P($G(BDMY(1)),"^",2))
;
PLTAX(P,A,S,F) ;EP - is DM on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
S S=$G(S)
S F=$G(F)
I F="" S F=1
N T S T=A ;$O(^ATXAX("B",A,0))
;I 'T Q ""
N X,Y,I,Z S (X,Y,I)=0,Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BDMUTL(Y,T,9)
.I S]"",$P(^AUPNPROB(X,0),U,12)'=S Q
.S I=1
.S Z=X
I F=1 Q I
I F=2 Q Z
Q ""
PLCODE(P,A,F) ;EP
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(F)="" S F=1
N T
;S T=+$$CODEN^ICDCODE(A,80)
S T=+$$CODEN^BDMUTL(A,80) ;cmi/maw 05/13/2014 patch 8 ICD-10
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 "" ;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,$$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 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)
LASTHF(P,C,F,BD,ED) ;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 ""
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
I $G(ED)="" S ED=DT
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
. I (9999999-D)<BD Q
. I (9999999-D)>ED Q
. 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)_" "_$$DATE^BDMS9B1((9999999-D))
I F="X" Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1((9999999-D))_U_(9999999-D)
Q 9999999-D
;
FRSTITEM(P,V,T,F) ;EP - return last item V
I $G(F)="" S F="D"
NEW BDMY,%,E,Y K BDMY S %=P_"^FIRST "_T_" "_V,E=$$START1^APCLDF(%,"BDMY(")
Q $S(F="D":$P($G(BDMY(1)),"^"),1:$P($G(BDMY(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)
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^BDMUTL(I,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
BDMSMU ; IHS/CMI/LAB - utilities for hmr ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9,10**;JUN 14, 2007;Build 12
+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(BDMSGHR)
Begin DoDot:1
+2 NEW A,B
+3 SET B=""
+4 SET BDMSGHR(1)=$SELECT($PIECE(^BDMSURV(BDMSITI,0),U,4)]"":$PIECE(^BDMSURV(BDMSITI,0),U,4),1:$PIECE(^BDMSURV(BDMSITI,0),U))
+5 SET BDMSGHR(2)=$GET(BDMLAST)
+6 SET BDMSGHR(3)=$$DATE($GET(BDMLAST))
+7 SET A=0
FOR
SET A=$ORDER(BDMSTEX(A))
IF A'=+A
QUIT
SET B=B_" "_BDMSTEX(A)
+8 SET BDMSGHR(4)=B
+9 SET BDMSGHR(5)=$GET(BDMNEXT)
+10 SET BDMSGHR(6)=$PIECE($GET(BDMICAR),U,4)
+11 SET BDMSGHR(7)=$PIECE($GET(BDMICAR),U,5)
+12 SET BDMSGHR(8)=$PIECE($GET(BDMICAR),U,6)
End DoDot:1
QUIT
+13 IF 'BDMSANY
DO FIRST
IF $DATA(BDMSQIT)
QUIT
SET BDMSANY=1
SET BDMSNPG=0
+14 XECUTE BDMSCKP
IF $DATA(BDMSQIT)
QUIT
+15 IF BDMSNPG
WRITE ?26,"LAST",?38,"NEXT",!
SET BDMSCT=0
SET BDMSNPG=0
+16 WRITE !,$SELECT($PIECE(^BDMSURV(BDMSITI,0),U,4)]"":$PIECE(^BDMSURV(BDMSITI,0),U,4),1:$PIECE(^BDMSURV(BDMSITI,0),U))
+17 WRITE ?26,$$DATE(BDMLAST)
+18 WRITE ?36,BDMSTEX(1)
FOR BDMSL=2:1
IF '$DATA(BDMSTEX(BDMSL))
QUIT
WRITE !,?36,BDMSTEX(BDMSL)
+19 SET BDMSCT=BDMSCT+1
+20 IF '(BDMSCT#2)
XECUTE BDMSCKP
IF $DATA(BDMSQIT)
QUIT
IF 'BDMSNPG
WRITE !
+21 KILL BDMSTEX
QUIT
+22 ;
FIRST ;EP
+1 XECUTE BDMSCKP
IF $DATA(BDMSQIT)
QUIT
IF 'BDMSNPG
XECUTE BDMSBRK
+2 WRITE ?26,"LAST",?38,"NEXT",!
+3 SET BDMSCT=0
+4 QUIT
+5 ;
INAC(X) ;EP - active?
+1 QUIT $PIECE($GET(^BDMSURV(X,0)),"^",3)
+2 ;
LASTLAB(P,BDMI,BDMT,BDML,BDMLT,F) ;EP P is patient, BDMI is ien of lab test, BDMT is IEN of lab taxonomy, BDML is ien of loinc code, BDMLT is ien o f loinc taxonmy
+1 IF $GET(F)=""
SET F="D"
+2 SET BDMC=""
+3 SET D=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(BDMC)
QUIT
Begin DoDot:1
+4 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BDMC)
QUIT
Begin DoDot:2
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BDMC)
QUIT
Begin DoDot:3
+6 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+7 IF $GET(BDMI)
IF L=BDMI
SET BDMC=(9999999-D)
QUIT
+8 IF $GET(BDMT)
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BDMC=(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(BDMLT),$GET(BDML))
QUIT
+12 SET BDMC=(9999999-D)
+13 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT BDMC
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
LASTITEM(P,V,T,F) ;EP - return last item V
+1 IF $GET(F)=""
SET F="D"
+2 NEW BDMY,%,E,Y
KILL BDMY
SET %=P_"^LAST "_T_" "_V
SET E=$$START1^APCLDF(%,"BDMY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(BDMY(1)),"^"),F="B":$PIECE($GET(BDMY(1)),"^")_"^"_$PIECE($GET(BDMY(1)),"^",2),1:$PIECE($GET(BDMY(1)),"^",2))
+4 ;
PLTAX(P,A,S,F) ;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 SET F=$GET(F)
+5 IF F=""
SET F=1
+6 ;$O(^ATXAX("B",A,0))
NEW T
SET T=A
+7 ;I 'T Q ""
+8 NEW X,Y,I,Z
SET (X,Y,I)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 IF '$$ICD^BDMUTL(Y,T,9)
QUIT
+12 IF S]""
IF $PIECE(^AUPNPROB(X,0),U,12)'=S
QUIT
+13 SET I=1
+14 SET Z=X
End DoDot:1
+15 IF F=1
QUIT I
+16 IF F=2
QUIT Z
+17 QUIT ""
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 ;S T=+$$CODEN^ICDCODE(A,80)
+6 ;cmi/maw 05/13/2014 patch 8 ICD-10
SET T=+$$CODEN^BDMUTL(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))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF Y=T
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,$$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 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)
LASTHF(P,C,F,BD,ED) ;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 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+7 IF $GET(ED)=""
SET ED=DT
+8 NEW H,D,O
SET H=0
KILL O
+9 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+11 SET D=$ORDER(^AUPNVHF("AA",P,H,""))
+12 IF 'D
QUIT
+13 IF (9999999-D)<BD
QUIT
+14 IF (9999999-D)>ED
QUIT
+15 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
+16 QUIT
End DoDot:1
+17 SET D=$ORDER(O(0))
+18 IF D=""
QUIT D
+19 IF F="N"
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)
+20 IF F="S"
QUIT $PIECE($GET(^AUPNVHF(O(D),0)),U,6)
+21 IF F="B"
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1((9999999-D))
+22 IF F="X"
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1((9999999-D))_U_(9999999-D)
+23 QUIT 9999999-D
+24 ;
FRSTITEM(P,V,T,F) ;EP - return last item V
+1 IF $GET(F)=""
SET F="D"
+2 NEW BDMY,%,E,Y
KILL BDMY
SET %=P_"^FIRST "_T_" "_V
SET E=$$START1^APCLDF(%,"BDMY(")
+3 QUIT $SELECT(F="D":$PIECE($GET(BDMY(1)),"^"),1:$PIECE($GET(BDMY(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)
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^BDMUTL(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
