BDMSMU.m

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