BHSDM6.m

BHSDM6 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;04-Aug-2011 14:33;MGH

 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6**;March 17, 2006;Build 5

 ;===================================================================

 ;Taken from APCHS9B6

 ;VA version of IHS components for supplemental summaries

 ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;  [ 02/20/04  1:53 PM ]

 ;;2.0;IHS RPMS/PCC Health Summary;**8,11,12**;JUN 24, 1997

 ;Patch 1 updates up to IHS patch 14

 ;Patch 2 code set versioning

 ;Patch 6 updated for tobacco changes

 ;===================================================================

DENTAL(P,APCHSED) ;EP

 NEW BHSY,DENTDATE,E

 K BHSY,DENTDATE

 NEW % S %=P_"^LAST EXAM DENTAL",E=$$START1^APCLDF(%,"BHSY(")

 S %=$P($G(BHSY(1)),U) I %]"" S DENTDATE=%

 I %]"",%>APCHSED Q "Yes   "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"

 K BHSY S %=P_"^LAST ADA [APCH DM ADA EXAMS",E=$$START1^APCLDF(%,"BHSY(")

 S %=$P($G(BHSY(1)),U) I %]"",%>APCHSED Q "Yes   "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"

 K BHSY,APCHV,^TMP($J,"DENTAL VISITS")

 S BHSY="^TMP($J,""DENTAL VISITS"",",%=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,BHSY)

 ;reorder by date of visit/reverse order

 S %=0 F  S %=$O(^TMP($J,"DENTAL VISITS",%)) Q:%'=+%  S APCHV(9999999-$P(^TMP($J,"DENTAL VISITS",%),U),$P(^TMP($J,"DENTAL VISITS",%),U,5))=""

 K ^TMP($J,"DENTAL VISITS")

 N PROV,D,V,G S (D,V)=0,G="" F  S D=$O(APCHV(D)) Q:D'=+D!(G)  S V=0 F  S V=$O(APCHV(D,V)) Q:V'=+V!(G)  S PROV=$$PRIMPROV^APCLV(V,"D") I PROV=52,$$ADA(V),'$$DNKA^BHSDM4(V) S G=9999999-D

 I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Dentist)"

 S (D,V)=0,G="" F  S D=$O(APCHV(D)) Q:D'=+D!(G)  S V=0 F  S V=$O(APCHV(D,V)) Q:V'=+V!(G)  S PROV=$$CLINIC^APCLV(V,"C") I (PROV=56!(PROV=99)),$$ADA(V),'$$DNKA^BHSDM4(V) S G=9999999-D

 I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"

 S G=$$REFDF^BHSDM3(P,9999999.15,$O(^AUTTEXAM("B","DENTAL EXAM",0)),$G(DENTDATE))

 I G]"" Q G

 S (D,V)=0,G="" F  S D=$O(APCHV(D)) Q:D'=+D!(G)  S V=0 F  S V=$O(APCHV(D,V)) Q:V'=+V!(G)  S PROV=$$CLINIC^APCLV(V,"C") I (PROV=56!(PROV=99)),$D(^AUPNVDEN("AD",V)),'$$ADA(V),'$$DNKA^BHSDM4(V) S G=9999999-D

 I G]"" Q "Patient Refused service (ada 9991) on "_$$FMTE^XLFDT(G)

 Q "No    "_$S($D(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")

 ;

TOBACCO ;EP

 K BHDTOB

 ;D TOBACCO3

 ;I $D(BHDTOB) Q

 D TOBACCO0

 I $D(BHDTOB) Q

 D TOBACCO3

 I $D(BHDTOB) Q

 D TOBACCO1 ;check Problem file for tobacco use

 I $D(BHDTOB) Q

 D TOBACCO2 ;check POVs for tobacco use

 I $D(BHDTOB) Q

 S BHDTOB="UNDOCUMENTED",BHDTOB="UNDOCUMENTED"

 Q

TOBACCO0 ;check for tobacco documented in health factors

 ;S X=$$LASTHF^BHSMU(BHSDFN,"TOBACCO","B") I X]"" S BHDTOB=X

 NEW CTGN,HF,HFDT,LIST,RESULT,X,BTIU,BHST,CTG

 I '$G(DFN) Q ""

 F BHST=1:1 D  Q:CTG=""

 .S CTG=$P($T(TOBU+BHST),";;",2)

 .Q:CTG=""

 .S CTGN=$O(^AUTTHF("B",CTG,0)) I 'CTGN Q    ;ien of category passed

 .;

 .S HF=0

 .F  S HF=$O(^AUTTHF("AC",CTGN,HF))  Q:'+HF  D        ;find health factors in category

 ..Q:'$D(^AUPNVHF("AA",DFN,HF))                     ;quit if patient doesn't have health factor

 ..S HFDT=$O(^AUPNVHF("AA",DFN,HF,"")) Q:'HFDT      ;get visit date for health factor

 ..S LIST(HFDT)=$O(^AUPNVHF("AA",DFN,HF,HFDT,""))   ;store iens by date

 ;

 I '$O(LIST(0)) Q

 S HFDT=$O(LIST(0))                                  ;find latest date (inverse dates)

 S RESULT=$$GET1^DIQ(9000010.23,LIST(HFDT),.01)

 S BHDTOB=RESULT_" "_$$FMTE^XLFDT(9999999-HFDT)

 Q

TOBU ;;

 ;;TOBACCO (EXPOSURE)

 ;;TOBACCO (SMOKELESS - CHEWING/DIP)

 ;;TOBACCO (SMOKING)

 ;

 Q

TOBACCO3 ;lookup in health status

 N C

 S C=$O(^AUTTHF("B","TOBACCO",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(^AUPNHF("AA",BHSDFN,H))

 .  S D=$O(^AUPNHF("AA",BHSDFN,H,""))

 .  Q:'D

 .  S O(D)=$O(^AUPNHF("AA",BHSDFN,H,D,""))

 .  Q

 S D=$O(O(0))

 I D="" Q

 S BHDTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))

 Q

TOBACCO1 ;check problem file for tobacco use

 K APCH,APCHX

 S APCHX=BHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E  I $D(APCH(1)) D

 . ;I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q

 . I $$ICDDX^ICDCODE($P(APCH(1),U,2),U,2)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q  ;code set versioning cmi/anch/maw 8/27/2007 code set versioning

 . S BHDTOB="YES, USES TOBACCO - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30)

 .Q

 Q

TOBACCO2 ;check pov file for TOBACCO USE DOC

 K APCH S APCHX=BHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E  I $D(APCH(1)) D

 . I $P(APCH(1),U,2)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30) Q

 . S BHDTOB="YES, USES TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30)

 .Q

 Q

 ;

CHEST(P) ;EP - get date of last chest xray from V RAD or V CPT

 ;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL

 I $G(P)="" Q ""

 NEW X,Y,Z,G,LCHEST,T,D

 S LCHEST=""

 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>71019&(Y<71040),V>LCHEST S LCHEST=V Q

 S T=71019 F  S T=$O(^ICPT("B",T)) Q:T>71039  S X=0 F  S X=$O(^ICPT("B",T,X)) Q:X'=+X  D

 .S D=$O(^AUPNVCPT("AA",P,X,0)) I D S D=9999999-D

 .I D,D>LCHEST S LCHEST=D

 K BHSY S %=P_"^LAST PROCEDURE 87.44",E=$$START1^APCLDF(%,"BHSY(")

 I $D(BHSY(1)),$P(BHSY(1),U)>LCHEST S LCHEST=$P(BHSY(1),U)

 K BHSY S %=P_"^LAST PROCEDURE 87.39",E=$$START1^APCLDF(%,"BHSY(")

 I $D(BHSY(1)),$P(BHSY(1),U)>LCHEST S LCHEST=$P(BHSY(1),U)

 Q $S(LCHEST]"":$$FMTE^XLFDT(LCHEST),1:"")

ADA(V) ;any ada other than 9991

 I '$G(V) Q ""

 NEW X,Y,Z,G

 S G="",X=0 F  S X=$O(^AUPNVDEN("AD",V,X)) Q:X'=+X!(G)  S Y=$P($G(^AUPNVDEN(X,0)),U) I Y,$D(^AUTTADA(Y,0)),$P(^AUTTADA(Y,0),U)'=9991 S G=1

 Q G

BHSDM6    ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;04-Aug-2011 14:33;MGH

 +1       ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6**;March 17, 2006;Build 5

 +2       ;===================================================================

 +3       ;Taken from APCHS9B6

 +4       ;VA version of IHS components for supplemental summaries

 +5       ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;  [ 02/20/04  1:53 PM ]

 +6       ;;2.0;IHS RPMS/PCC Health Summary;**8,11,12**;JUN 24, 1997

 +7       ;Patch 1 updates up to IHS patch 14

 +8       ;Patch 2 code set versioning

 +9       ;Patch 6 updated for tobacco changes

 +10      ;===================================================================

DENTAL(P,APCHSED) ;EP

 +1        NEW BHSY,DENTDATE,E

 +2        KILL BHSY,DENTDATE

 +3        NEW %

           SET %=P_"^LAST EXAM DENTAL"

           SET E=$$START1^APCLDF(%,"BHSY(")

 +4        SET %=$PIECE($GET(BHSY(1)),U)

           IF %]""

               SET DENTDATE=%

 +5        IF %]""

               IF %>APCHSED

                   QUIT "Yes   "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"

 +6        KILL BHSY

           SET %=P_"^LAST ADA [APCH DM ADA EXAMS"

           SET E=$$START1^APCLDF(%,"BHSY(")

 +7        SET %=$PIECE($GET(BHSY(1)),U)

           IF %]""

               IF %>APCHSED

                   QUIT "Yes   "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"

 +8        KILL BHSY,APCHV,^TMP($JOB,"DENTAL VISITS")

 +9        SET BHSY="^TMP($J,""DENTAL VISITS"","

           SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT)

           SET E=$$START1^APCLDF(%,BHSY)

 +10      ;reorder by date of visit/reverse order

 +11       SET %=0

           FOR 

               SET %=$ORDER(^TMP($JOB,"DENTAL VISITS",%))

               IF %'=+%

                   QUIT 

               SET APCHV(9999999-$PIECE(^TMP($JOB,"DENTAL VISITS",%),U),$PIECE(^TMP($JOB,"DENTAL VISITS",%),U,5))=""

 +12       KILL ^TMP($JOB,"DENTAL VISITS")

 +13       NEW PROV,D,V,G

           SET (D,V)=0

           SET G=""

           FOR 

               SET D=$ORDER(APCHV(D))

               IF D'=+D!(G)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(APCHV(D,V))

                   IF V'=+V!(G)

                       QUIT 

                   SET PROV=$$PRIMPROV^APCLV(V,"D")

                   IF PROV=52

                       IF $$ADA(V)

                           IF '$$DNKA^BHSDM4(V)

                               SET G=9999999-D

 +14       IF G]""

               QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Dentist)"

 +15       SET (D,V)=0

           SET G=""

           FOR 

               SET D=$ORDER(APCHV(D))

               IF D'=+D!(G)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(APCHV(D,V))

                   IF V'=+V!(G)

                       QUIT 

                   SET PROV=$$CLINIC^APCLV(V,"C")

                   IF (PROV=56!(PROV=99))

                       IF $$ADA(V)

                           IF '$$DNKA^BHSDM4(V)

                               SET G=9999999-D

 +16       IF G]""

               QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"

 +17       SET G=$$REFDF^BHSDM3(P,9999999.15,$ORDER(^AUTTEXAM("B","DENTAL EXAM",0)),$GET(DENTDATE))

 +18       IF G]""

               QUIT G

 +19       SET (D,V)=0

           SET G=""

           FOR 

               SET D=$ORDER(APCHV(D))

               IF D'=+D!(G)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(APCHV(D,V))

                   IF V'=+V!(G)

                       QUIT 

                   SET PROV=$$CLINIC^APCLV(V,"C")

                   IF (PROV=56!(PROV=99))

                       IF $DATA(^AUPNVDEN("AD",V))

                           IF '$$ADA(V)

                               IF '$$DNKA^BHSDM4(V)

                                   SET G=9999999-D

 +20       IF G]""

               QUIT "Patient Refused service (ada 9991) on "_$$FMTE^XLFDT(G)

 +21       QUIT "No    "_$SELECT($DATA(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")

 +22      ;

TOBACCO   ;EP

 +1        KILL BHDTOB

 +2       ;D TOBACCO3

 +3       ;I $D(BHDTOB) Q

 +4        DO TOBACCO0

 +5        IF $DATA(BHDTOB)

               QUIT 

 +6        DO TOBACCO3

 +7        IF $DATA(BHDTOB)

               QUIT 

 +8       ;check Problem file for tobacco use

           DO TOBACCO1

 +9        IF $DATA(BHDTOB)

               QUIT 

 +10      ;check POVs for tobacco use

           DO TOBACCO2

 +11       IF $DATA(BHDTOB)

               QUIT 

 +12       SET BHDTOB="UNDOCUMENTED"

           SET BHDTOB="UNDOCUMENTED"

 +13       QUIT 

TOBACCO0  ;check for tobacco documented in health factors

 +1       ;S X=$$LASTHF^BHSMU(BHSDFN,"TOBACCO","B") I X]"" S BHDTOB=X

 +2        NEW CTGN,HF,HFDT,LIST,RESULT,X,BTIU,BHST,CTG

 +3        IF '$GET(DFN)

               QUIT ""

 +4        FOR BHST=1:1

               Begin DoDot:1

 +5                SET CTG=$PIECE($TEXT(TOBU+BHST),";;",2)

 +6                IF CTG=""

                       QUIT 

 +7       ;ien of category passed

                   SET CTGN=$ORDER(^AUTTHF("B",CTG,0))

                   IF 'CTGN

                       QUIT 

 +8       ;

 +9                SET HF=0

 +10      ;find health factors in category

                   FOR 

                       SET HF=$ORDER(^AUTTHF("AC",CTGN,HF))

                       IF '+HF

                           QUIT 

                       Begin DoDot:2

 +11      ;quit if patient doesn't have health factor

                           IF '$DATA(^AUPNVHF("AA",DFN,HF))

                               QUIT 

 +12      ;get visit date for health factor

                           SET HFDT=$ORDER(^AUPNVHF("AA",DFN,HF,""))

                           IF 'HFDT

                               QUIT 

 +13      ;store iens by date

                           SET LIST(HFDT)=$ORDER(^AUPNVHF("AA",DFN,HF,HFDT,""))

                       End DoDot:2

               End DoDot:1

               IF CTG=""

                   QUIT 

 +14      ;

 +15       IF '$ORDER(LIST(0))

               QUIT 

 +16      ;find latest date (inverse dates)

           SET HFDT=$ORDER(LIST(0))

 +17       SET RESULT=$$GET1^DIQ(9000010.23,LIST(HFDT),.01)

 +18       SET BHDTOB=RESULT_" "_$$FMTE^XLFDT(9999999-HFDT)

 +19       QUIT 

TOBU      ;;

 +1       ;;TOBACCO (EXPOSURE)

 +2       ;;TOBACCO (SMOKELESS - CHEWING/DIP)

 +3       ;;TOBACCO (SMOKING)

 +4       ;

 +5        QUIT 

TOBACCO3  ;lookup in health status

 +1        NEW C

 +2       ;ien of category passed

           SET C=$ORDER(^AUTTHF("B","TOBACCO",0))

 +3        IF '$GET(C)

               QUIT 

 +4        NEW H,D,O

           SET H=0

           KILL O

 +5        FOR 

               SET H=$ORDER(^AUTTHF("AC",C,H))

               IF '+H

                   QUIT 

               Begin DoDot:1

 +6                IF '$DATA(^AUPNHF("AA",BHSDFN,H))

                       QUIT 

 +7                SET D=$ORDER(^AUPNHF("AA",BHSDFN,H,""))

 +8                IF 'D

                       QUIT 

 +9                SET O(D)=$ORDER(^AUPNHF("AA",BHSDFN,H,D,""))

 +10               QUIT 

               End DoDot:1

 +11       SET D=$ORDER(O(0))

 +12       IF D=""

               QUIT 

 +13       SET BHDTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))

 +14       QUIT 

TOBACCO1  ;check problem file for tobacco use

 +1        KILL APCH,APCHX

 +2        SET APCHX=BHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"

           SET E=$$START1^APCLDF(APCHX,"APCH(")

           IF E

               QUIT 

           IF $DATA(APCH(1))

               Begin DoDot:1

 +3       ;I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q

 +4       ;code set versioning cmi/anch/maw 8/27/2007 code set versioning

                   IF $$ICDDX^ICDCODE($PIECE(APCH(1),U,2),U,2)=305.13

                       SET BHDTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)

                       QUIT 

 +5                SET BHDTOB="YES, USES TOBACCO - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

TOBACCO2  ;check pov file for TOBACCO USE DOC

 +1        KILL APCH

           SET APCHX=BHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS"

           SET E=$$START1^APCLDF(APCHX,"APCH(")

           IF E

               QUIT 

           IF $DATA(APCH(1))

               Begin DoDot:1

 +2                IF $PIECE(APCH(1),U,2)=305.13

                       SET BHDTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)

                       QUIT 

 +3                SET BHDTOB="YES, USES TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)

 +4                QUIT 

               End DoDot:1

 +5        QUIT 

 +6       ;

CHEST(P)  ;EP - get date of last chest xray from V RAD or V CPT

 +1       ;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL

 +2        IF $GET(P)=""

               QUIT ""

 +3        NEW X,Y,Z,G,LCHEST,T,D

 +4        SET LCHEST=""

 +5        SET (X,Y,V)=0

           FOR 

               SET X=$ORDER(^AUPNVRAD("AC",P,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET V=$PIECE(^AUPNVRAD(X,0),U,3)

                   SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

 +7                SET Y=$PIECE(^AUPNVRAD(X,0),U)

                   SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)

 +8                IF Y>71019&(Y<71040)

                       IF V>LCHEST

                           SET LCHEST=V

                           QUIT 

               End DoDot:1

 +9        SET T=71019

           FOR 

               SET T=$ORDER(^ICPT("B",T))

               IF T>71039

                   QUIT 

               SET X=0

               FOR 

                   SET X=$ORDER(^ICPT("B",T,X))

                   IF X'=+X

                       QUIT 

                   Begin DoDot:1

 +10                   SET D=$ORDER(^AUPNVCPT("AA",P,X,0))

                       IF D

                           SET D=9999999-D

 +11                   IF D

                           IF D>LCHEST

                               SET LCHEST=D

                   End DoDot:1

 +12       KILL BHSY

           SET %=P_"^LAST PROCEDURE 87.44"

           SET E=$$START1^APCLDF(%,"BHSY(")

 +13       IF $DATA(BHSY(1))

               IF $PIECE(BHSY(1),U)>LCHEST

                   SET LCHEST=$PIECE(BHSY(1),U)

 +14       KILL BHSY

           SET %=P_"^LAST PROCEDURE 87.39"

           SET E=$$START1^APCLDF(%,"BHSY(")

 +15       IF $DATA(BHSY(1))

               IF $PIECE(BHSY(1),U)>LCHEST

                   SET LCHEST=$PIECE(BHSY(1),U)

 +16       QUIT $SELECT(LCHEST]"":$$FMTE^XLFDT(LCHEST),1:"")

ADA(V)    ;any ada other than 9991

 +1        IF '$GET(V)

               QUIT ""

 +2        NEW X,Y,Z,G

 +3        SET G=""

           SET X=0

           FOR 

               SET X=$ORDER(^AUPNVDEN("AD",V,X))

               IF X'=+X!(G)

                   QUIT 

               SET Y=$PIECE($GET(^AUPNVDEN(X,0)),U)

               IF Y

                   IF $DATA(^AUTTADA(Y,0))

                       IF $PIECE(^AUTTADA(Y,0),U)'=9991

                           SET G=1

 +4        QUIT G