Routine: APCLACG1

APCLACG1 ; IHS/CMI/LAB - IHS GPRA 09 SELECTED REPORT DRIVER 21 May 2008 12:10 PM ; 11 Dec 2009  6:32 AM

 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

PROC ;EP

 S APCLJOB=$J,APCLBTH=$H,(APCLUPOP,APCLUPWR,APCLUPAC,APCLRPOP,APCLRPWR,APCLRPAC,APCLRPWA,APCLRPIN,APCLRPI9,APCLRPVK,APCLRPMI,APCLRPMN,APCLRPNI,APCLRPNN,APCLRPMU,APCLRPNU)=0

 K ^TMP($J)

 K APCLEHRL

 I APCLGRP="E" D PLSTPTS^BEHOPTP2(.APCLEHRL,$P(APCLICP,U,2)) D

 .S X=0 F  S X=$O(APCLEHRL(X)) Q:X'=+X  S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",$P(APCLEHRL(X),U,1))="",APCLRPOP=APCLRPOP+1

 K APCLEHRL

 I APCLGRP="I" D RET^BQIPLDFN(.APCLEHRL,DUZ,$P(APCLICP,U,2)) D

 .S X=0 F  S X=$O(^TMP("BQIPLDFN",$J,X)) Q:X'=+X  I ^TMP("BQIPLDFN",$J,X) S ^XTMP("APCLACG",APCLJOB,APCLBTH,^TMP("BQIPLDFN",$J,X))="",APCLRPOP=APCLRPOP+1

 D XTMP^APCLOSUT("APCLACG",DT)

 S APCL3YE=$$FMADD^XLFDT(APCLED,(3*-365))

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D

 .Q:'$D(^DPT(DFN,0))

 .S (APCLUP,APCLFAC,APCLPTWR,APCLPTAC,APCLWRAC,APCLPINR,APCLPTI9,APCLPTVK,APCLPTMI,APCLPTMN,APCLPTNI,APCLPTNN,APCLPTMU,APCLPTNU)=0

 .S APCLUP=0  ;PATIENT USER POP FLAG

 .S APCLPTWR=0 ;PATIENT WARFARIN FLAG

 .S APCLPTAC=0  ;PATIENT AC CLINIC FLAG

 .S APCLWRAC=0  ;patient on warfarin and ac clinic visit

 .S APCLUP=$$ACTUP(DFN,APCL3YE,APCLED,APCLTAXI)

 .I APCLUP S APCLUPOP=APCLUPOP+1  ;,^XTMP("APCLACG",APCLJ,APCLH,"LIST 1",DFN)=""  ;TOTAL USER POP COUNTER

 .I 'APCLUP G RPTPOP

 .K APCLV

 .K APCLMEDS

 .D GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCLMEDS)

 .I $D(APCLMEDS) S APCLPTWR=1 I APCLUP S APCLUPWR=APCLUPWR+1

 .S APCLV="APCLV"

 .D ALLV^APCLAPIU(DFN,APCLBD,APCLED,.APCLV)

 .;now see if any visit is to one of the anticoag clinics

 .S X=0 F  S X=$O(APCLV(X)) Q:X'=+X!(APCLPTAC)  D

 ..S V=$P(APCLV(X),U,5)

 ..S C=$P(^AUPNVSIT(V,0),U,8)

 ..Q:C=""

 ..I $D(APCLACCL(C)) S APCLPTAC=1

 .I APCLPTAC,APCLPTWR S APCLWRAC=1 I APCLUP S APCLUPAC=APCLUPAC+1

.;

RPTPOP .;

 .;GET all patients in the report pop into ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS") and count in APCLRPOP

 .I APCLGRP="W",APCLPTWR S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1

 .I APCLGRP="A",APCLPTAC S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1

 .I APCLGRP="S",$D(^DIBT(APCLSTMP,1,DFN)) S ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)="",APCLRPOP=APCLRPOP+1

 .I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTAC S APCLRPAC=APCLRPAC+1

 .I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTWR S APCLRPWR=APCLRPWR+1

 .I $D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)),APCLPTWR,APCLPTAC S APCLRPWA=APCLRPWA+1

 .Q:'$D(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))  ;rest is for report pop only

 .K APCLINR

 .S APCLV="APCLINR"

 .D ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,$O(^ATXLAB("B","BJPC INR LAB TESTS",0)),$O(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.APCLV)

 .S X=0 F  S X=$O(APCLINR(X)) Q:X'=+X  D

 ..S APCLPINR=1  ;had an INR

 ..I $P(APCLINR(X),U,3)>9 S APCLPTI9=1

 .;if had at least 1 >9 table all of them for display later

 .I APCLPTI9 S APCLRPI9=APCLRPI9+1 S X=0 F  S X=$O(APCLINR(X)) Q:X'=+X  S ^XTMP("APCLACG",APCLJOB,APCLBTH,"INR >9",DFN,$P(APCLINR(X),U,1),$P(APCLINR(X),U,4))=$P(APCLINR(X),U,3)

 .I APCLPINR S APCLRPIN=APCLRPIN+1

 .;VITAMIN K

 .K APCLMEDS

 .D GETMEDS^APCHSMU1(DFN,APCLBD,APCLED,,,,"PHYTONADIONE",.APCLMEDS)

 .I $D(APCLMEDS) S APCLPTVK=1 S APCLRPVK=APCLRPVK+1

 .S X=0,D="" F  S X=$O(APCLMEDS(X)) Q:X'=+X  S D=$P(APCLMEDS(X),U,1)

 .I APCLPTVK S ^XTMP("APCLACG",APCLJOB,APCLBTH,"VITK",DFN)=D

MONT .;THOSE on warfarin and monitored were they within range

 .I APCLWRAC D  Q

 ..;get last INR value in date range

 ..S APCLLINR=$P($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)

 ..;get last goal in date range

 ..S APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)

 ..I APCLLINR=""!(APCLGINR="")!(+APCLLINR=0) S APCLPTMU=1,APCLRPMU=APCLRPMU+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR Q

 ..S L=$P(APCLGINR," - ",1)

 ..S H=$P(APCLGINR," - ",2)

 ..I APCLLINR'<L,APCLLINR'>H S APCLPTMI=1,APCLRPMI=APCLRPMI+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR Q

 ..S APCLPTMN=1,APCLRPMN=APCLRPMN+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR

NOTMONT .;NOT MONITORED

 .I APCLPTWR,'APCLPTAC D

 ..;get last INR value in date range

 ..S APCLLINR=$P($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)

 ..;get last goal in date range

 ..S APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)

 ..I APCLLINR=""!(APCLGINR="")!(+APCLLINR=0) S APCLPTNU=1,APCLRPNU=APCLRPNU+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR Q

 ..S L=$P(APCLGINR," - ",1)

 ..S H=$P(APCLGINR," - ",2)

 ..I APCLLINR'<L,APCLLINR'>H S APCLPTNI=1,APCLRPNI=APCLRPNI+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR Q

 ..S APCLPTNN=1,APCLRPNN=APCLRPNN+1,^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR

ACTUP(P,BDATE,EDATE,T) ;EP - is this patient in user pop?

 ;I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0  ;must be Indian/Alaskan Native

 ;I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0  ;must not be I/A

 NEW DOD

 S DOD=$$DOD^AUPNPAT(P) I DOD]"",DOD<EDATE Q 0

 S X=$P($G(^AUPNPAT(P,11)),U,18) I X="" Q 0

 I '$D(^ATXAX(T,21,"B",($P(^AUPNPAT(P,11),U,18)))),'$D(^ATXAX(T,21,"AA",$P(^AUPNPAT(P,11),U,18),$P(^AUPNPAT(P,11),U,18))) Q 0

 S X=$$LASTVD(P,BDATE,EDATE)

 Q $S(X:1,1:0)

LASTVD(P,BDATE,EDATE) ;

 I '$D(^AUPNVSIT("AC",P)) Q ""

 NEW APCHV,A,B,G,X

 S APCLV="APCLV"

 D ALLV^APCLAPIU(P,BDATE,EDATE,.APCLV)

 S (X,G)=0 F  S X=$O(APCLV(X)) Q:X'=+X!(G)  S V=$P(APCLV(X),U,5) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:'$D(^AUPNVPRV("AD",V))

 .Q:"SAHOM"'[$P(^AUPNVSIT(V,0),U,7)

 .Q:"V"[$P(^AUPNVSIT(V,0),U,3)

 .Q:$P(^AUPNVSIT(V,0),U,6)=""

 .S G=1

.Q

Q G

APCLACG1  ; IHS/CMI/LAB - IHS GPRA 09 SELECTED REPORT DRIVER 21 May 2008 12:10 PM ; 11 Dec 2009  6:32 AM

 +1       ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009

 +2       ;

PROC      ;EP

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

           SET (APCLUPOP,APCLUPWR,APCLUPAC,APCLRPOP,APCLRPWR,APCLRPAC,APCLRPWA,APCLRPIN,APCLRPI9,APCLRPVK,APCLRPMI,APCLRPMN,APCLRPNI,APCLRPNN,APCLRPMU,APCLRPNU)=0

 +2        KILL ^TMP($JOB)

 +3        KILL APCLEHRL

 +4        IF APCLGRP="E"

               DO PLSTPTS^BEHOPTP2(.APCLEHRL,$PIECE(APCLICP,U,2))

               Begin DoDot:1

 +5                SET X=0

FOR

                       SET X=$ORDER(APCLEHRL(X))

                       IF X'=+X

                           QUIT

                       SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",$PIECE(APCLEHRL(X),U,1))=""

                       SET APCLRPOP=APCLRPOP+1

               End DoDot:1

 +6        KILL APCLEHRL

 +7        IF APCLGRP="I"

               DO RET^BQIPLDFN(.APCLEHRL,DUZ,$PIECE(APCLICP,U,2))

               Begin DoDot:1

 +8                SET X=0

FOR

                       SET X=$ORDER(^TMP("BQIPLDFN",$JOB,X))

                       IF X'=+X

                           QUIT

                       IF ^TMP("BQIPLDFN",$JOB,X)

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,^TMP("BQIPLDFN",$JOB,X))=""

                           SET APCLRPOP=APCLRPOP+1

               End DoDot:1

 +9        DO XTMP^APCLOSUT("APCLACG",DT)

 +10       SET APCL3YE=$$FMADD^XLFDT(APCLED,(3*-365))

 +11       SET DFN=0

FOR

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT

               Begin DoDot:1

 +12               IF '$DATA(^DPT(DFN,0))

                       QUIT

 +13               SET (APCLUP,APCLFAC,APCLPTWR,APCLPTAC,APCLWRAC,APCLPINR,APCLPTI9,APCLPTVK,APCLPTMI,APCLPTMN,APCLPTNI,APCLPTNN,APCLPTMU,APCLPTNU)=0

 +14      ;PATIENT USER POP FLAG

                   SET APCLUP=0

 +15      ;PATIENT WARFARIN FLAG

                   SET APCLPTWR=0

 +16      ;PATIENT AC CLINIC FLAG

                   SET APCLPTAC=0

 +17      ;patient on warfarin and ac clinic visit

                   SET APCLWRAC=0

 +18               SET APCLUP=$$ACTUP(DFN,APCL3YE,APCLED,APCLTAXI)

 +19      ;,^XTMP("APCLACG",APCLJ,APCLH,"LIST 1",DFN)=""  ;TOTAL USER POP COUNTER

                   IF APCLUP

                       SET APCLUPOP=APCLUPOP+1

 +20               IF 'APCLUP

                       GOTO RPTPOP

 +21               KILL APCLV

 +22               KILL APCLMEDS

 +23               DO GETMEDS^APCHSMU1(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,"BGP CMS WARFARIN MEDS",,,"WARFARIN",.APCLMEDS)

 +24               IF $DATA(APCLMEDS)

                       SET APCLPTWR=1

                       IF APCLUP

                           SET APCLUPWR=APCLUPWR+1

 +25               SET APCLV="APCLV"

 +26               DO ALLV^APCLAPIU(DFN,APCLBD,APCLED,.APCLV)

 +27      ;now see if any visit is to one of the anticoag clinics

 +28               SET X=0

FOR

                       SET X=$ORDER(APCLV(X))

                       IF X'=+X!(APCLPTAC)

                           QUIT

                       Begin DoDot:2

 +29                       SET V=$PIECE(APCLV(X),U,5)

 +30                       SET C=$PIECE(^AUPNVSIT(V,0),U,8)

 +31                       IF C=""

                               QUIT

 +32                       IF $DATA(APCLACCL(C))

                               SET APCLPTAC=1

                       End DoDot:2

 +33               IF APCLPTAC

                       IF APCLPTWR

                           SET APCLWRAC=1

                           IF APCLUP

                               SET APCLUPAC=APCLUPAC+1

 +34      ;

RPTPOP    ;

 +1       ;GET all patients in the report pop into ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS") and count in APCLRPOP

 +2                IF APCLGRP="W"

                       IF APCLPTWR

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""

                           SET APCLRPOP=APCLRPOP+1

 +3                IF APCLGRP="A"

                       IF APCLPTAC

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""

                           SET APCLRPOP=APCLRPOP+1

 +4                IF APCLGRP="S"

                       IF $DATA(^DIBT(APCLSTMP,1,DFN))

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN)=""

                           SET APCLRPOP=APCLRPOP+1

 +5                IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))

                       IF APCLPTAC

                           SET APCLRPAC=APCLRPAC+1

 +6                IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))

                       IF APCLPTWR

                           SET APCLRPWR=APCLRPWR+1

 +7                IF $DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))

                       IF APCLPTWR

                           IF APCLPTAC

                               SET APCLRPWA=APCLRPWA+1

 +8       ;rest is for report pop only

                   IF '$DATA(^XTMP("APCLACG",APCLJOB,APCLBTH,"PATIENTS",DFN))

                       QUIT

 +9                KILL APCLINR

 +10               SET APCLV="APCLINR"

 +11               DO ALLLAB^APCLAPIU(DFN,$$FMADD^XLFDT(APCLED,-45),APCLED,$ORDER(^ATXLAB("B","BJPC INR LAB TESTS",0)),$ORDER(^ATXAX("B","BJPC INR LAB LOINCS",0)),"INR",.APCLV)

 +12               SET X=0

FOR

                       SET X=$ORDER(APCLINR(X))

                       IF X'=+X

                           QUIT

                       Begin DoDot:2

 +13      ;had an INR

                           SET APCLPINR=1

 +14                       IF $PIECE(APCLINR(X),U,3)>9

                               SET APCLPTI9=1

                       End DoDot:2

 +15      ;if had at least 1 >9 table all of them for display later

 +16               IF APCLPTI9

                       SET APCLRPI9=APCLRPI9+1

                       SET X=0

FOR

                           SET X=$ORDER(APCLINR(X))

                           IF X'=+X

                               QUIT

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"INR >9",DFN,$PIECE(APCLINR(X),U,1),$PIECE(APCLINR(X),U,4))=$PIECE(APCLINR(X),U,3)

 +17               IF APCLPINR

                       SET APCLRPIN=APCLRPIN+1

 +18      ;VITAMIN K

 +19               KILL APCLMEDS

 +20               DO GETMEDS^APCHSMU1(DFN,APCLBD,APCLED,,,,"PHYTONADIONE",.APCLMEDS)

 +21               IF $DATA(APCLMEDS)

                       SET APCLPTVK=1

                       SET APCLRPVK=APCLRPVK+1

 +22               SET X=0

                   SET D=""

FOR

                       SET X=$ORDER(APCLMEDS(X))

                       IF X'=+X

                           QUIT

                       SET D=$PIECE(APCLMEDS(X),U,1)

 +23               IF APCLPTVK

                       SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"VITK",DFN)=D

MONT      ;THOSE on warfarin and monitored were they within range

 +1                IF APCLWRAC

                       Begin DoDot:2

 +2       ;get last INR value in date range

 +3                        SET APCLLINR=$PIECE($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)

 +4       ;get last goal in date range

 +5                        SET APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)

 +6                        IF APCLLINR=""!(APCLGINR="")!(+APCLLINR=0)

                               SET APCLPTMU=1

                               SET APCLRPMU=APCLRPMU+1

                               SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR

                               QUIT

 +7                        SET L=$PIECE(APCLGINR," - ",1)

 +8                        SET H=$PIECE(APCLGINR," - ",2)

 +9                        IF APCLLINR'<L

                               IF APCLLINR'>H

                                   SET APCLPTMI=1

                                   SET APCLRPMI=APCLRPMI+1

                                   SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR

                                   QUIT

 +10                       SET APCLPTMN=1

                           SET APCLRPMN=APCLRPMN+1

                           SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR

                       End DoDot:2

                       QUIT

NOTMONT   ;NOT MONITORED

 +1                IF APCLPTWR

                       IF 'APCLPTAC

                           Begin DoDot:2

 +2       ;get last INR value in date range

 +3                            SET APCLLINR=$PIECE($$LASTINR^APCLACGM(DFN,APCLBD,APCLED),U,3)

 +4       ;get last goal in date range

 +5                            SET APCLGINR=$$INRGOAL^APCLACGM(DFN,APCLED)

 +6                            IF APCLLINR=""!(APCLGINR="")!(+APCLLINR=0)

                                   SET APCLPTNU=1

                                   SET APCLRPNU=APCLRPNU+1

                                   SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT UNABLE TO ASSESS",DFN)=APCLLINR_U_APCLGINR

                                   QUIT

 +7                            SET L=$PIECE(APCLGINR," - ",1)

 +8                            SET H=$PIECE(APCLGINR," - ",2)

 +9                            IF APCLLINR'<L

                                   IF APCLLINR'>H

                                       SET APCLPTNI=1

                                       SET APCLRPNI=APCLRPNI+1

                                       SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT IN RANGE",DFN)=APCLLINR_U_APCLGINR

                                       QUIT

 +10                           SET APCLPTNN=1

                               SET APCLRPNN=APCLRPNN+1

                               SET ^XTMP("APCLACG",APCLJOB,APCLBTH,"NOT MONT NOT IN RANGE",DFN)=APCLLINR_U_APCLGINR

                           End DoDot:2

               End DoDot:1

 +11       QUIT

ACTUP(P,BDATE,EDATE,T) ;EP - is this patient in user pop?

 +1       ;I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0  ;must be Indian/Alaskan Native

 +2       ;I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0  ;must not be I/A

 +3        NEW DOD

 +4        SET DOD=$$DOD^AUPNPAT(P)

           IF DOD]""

               IF DOD<EDATE

                   QUIT 0

 +5        SET X=$PIECE($GET(^AUPNPAT(P,11)),U,18)

           IF X=""

               QUIT 0

 +6        IF '$DATA(^ATXAX(T,21,"B",($PIECE(^AUPNPAT(P,11),U,18))))

               IF '$DATA(^ATXAX(T,21,"AA",$PIECE(^AUPNPAT(P,11),U,18),$PIECE(^AUPNPAT(P,11),U,18)))

                   QUIT 0

 +7        SET X=$$LASTVD(P,BDATE,EDATE)

 +8        QUIT $SELECT(X:1,1:0)

 +9       ;

LASTVD(P,BDATE,EDATE) ;

 +1        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +2        NEW APCHV,A,B,G,X

 +3        SET APCLV="APCLV"

 +4        DO ALLV^APCLAPIU(P,BDATE,EDATE,.APCLV)

 +5        SET (X,G)=0

FOR

               SET X=$ORDER(APCLV(X))

               IF X'=+X!(G)

                   QUIT

               SET V=$PIECE(APCLV(X),U,5)

               Begin DoDot:1

 +6                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT

 +7                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT

 +8                IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT

 +9                IF '$DATA(^AUPNVPRV("AD",V))

                       QUIT

 +10               IF "SAHOM"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT

 +11               IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)

                       QUIT

 +12               IF $PIECE(^AUPNVSIT(V,0),U,6)=""

                       QUIT

 +13               SET G=1

 +14               QUIT

               End DoDot:1

 +15       QUIT G

APCLACG1.m