APCM14E1.m

APCM14E1 ; IHS/CMI/LAB - IHS MU 24 Feb 2014 10:32 AM ; 

 ;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65

 ;

BQI(BQIGREF,APCMPRV) ;PEP-Call from iCare

 ; input

 ; BQIGREF - Global reference

 ; APCMPRV - Array of providers

 ;

PROC ;EP

 S APCMBT=$H

 ;D JRNL^APCM1UTL

 S APCMJ=$J,APCMH=$H

 D XTMP^APCM1UTL("APCM1D","MU Patient List")

 ;process each patient

 ;first gather up provider exclusions

 I APCMRPTT=2 D  G PROC1  ;hospital report doesn't need this stuff for exclusions

 .K APCMOFFV

 .K APCM14ON  ;SMK STATUS EXCL

 .K APCMIMME  ;IMM EXCL

 .K APCMHO65  ;ADV DIR EXCL

 .S X=APCMFAC  S APCMX=$$VSTH(APCMFAC,APCMBD,APCMED,APCMMETH) D

 ..I '$P(APCMX,U,3) S APCM14ON(X,1)=""  ;SMOKING STATUS EXCL

 ..I '$P(APCMX,U,1) S APCMOFFV(X,1)=""

 ..I '$P(APCMX,U,5) S APCMIMME(X,1)=""  ;IMM REG

 ..I '$P(APCMX,U,7) S APCMHO65(X,1)=""  ;ADV DIR EXCL

 .;

 K APCM100R

 S X=0 F  S X=$O(APCMPRV(X)) Q:X'=+X  I '$$H100(X,APCMBD,APCMED) S APCM100R(X,1)=""  ;S1.003.EP E-RX EXCL, DRUG FORM EXCL

 K APCMOFFV

 K APCM14ON

 K APCMIMME

 S X=0 F  S X=$O(APCMPRV(X)) Q:X'=+X  S APCMX=$$VST(X,APCMBD,APCMED) D

 .I '$P(APCMX,U,3) S APCM14ON(X,1)=""  ;SMK STATUS EXCL

 .I '$P(APCMX,U,1) S APCMOFFV(X,1)=""  ;CLIN SUM EXCL

 .I '$P(APCMX,U,5) S APCMIMME(X,1)=""  ;IMM REG EXCL

N1 ;

 ;any patients 0-5 or >64?

 S APCMN565(1)=1

 S P=0 F  S P=$O(^DPT(P)) Q:P'=+P!(APCMN565(1)=0)  D

 .S X=$$DOD^AUPNPAT(P)

 .I X,X'>APCMED Q

 .Q:$$DOB^AUPNPAT(P)>APCMBD  ;born after time period begin date

 .S X=$P($G(^AUPNPAT(P,41,DUZ(2),0)),U,3)

 .I X,X'>APCMED Q

 .S A=$$AGE^AUPNPAT(P,APCMBD)

 .I A<6 S APCMN565(1)=0 Q

 .I A>64 S APCMN565(1)=0 Q

 ;

PROC1 ;

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

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

 .;I DUZ=2793 Q:'$D(^DIBT(4723,1,DFN))

 .;I DUZ=2793 Q:DFN'=5851

 .Q:$$DEMO^APCLUTL(DFN,$G(APCMDEMO))

 .D PROCCY

N ;

 ;NOW DO ATTESTATION MEASURES

 D PROCACY

 S APCMET=$H

 Q

 ;

PROCCY ;EP - current time period

 K ^TMP($J)

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

 Q:$P(^DPT(DFN,0),U,2)=""

 S APCMEDAT=APCMED,APCMTIME=1,APCMBDAT=APCMBD,APCMGBL="^APCMM14C(",APCMFILN=9001302.0311

 S APCMAGEB=$$AGE^AUPNPAT(DFN,APCMBDAT)

 S APCMAGEE=$$AGE^AUPNPAT(DFN,APCMEDAT)

 S APCMSEX=$P(^DPT(DFN,0),U,2)

 ;had visit to each provider?

 D CALCIND

 K ^TMP($J,"A")

 Q

CALCIND ;

 D CALCIND^APCM14CI

 Q

PROCACY ;EP - current time period

 S APCMEDAT=APCMED,APCMTIME=1,APCMBDAT=APCMBD,APCMGBL="^APCMM14C(",APCMFILN=9001302.0311

 D CALCINDA^APCM14CI

 Q

S(RPT,IND,VALUE,PROV,RT,T,F,NT) ;EP - set counter

 NEW N,P,Y,J,I,ID

 I VALUE="" Q  ;no value to add

 I RT=1 S I=PROV_";VA(200,"

 I RT=2 S I=PROV_";AUTTLOC("

 I T=1 D  Q

 .I $G(BQIGREF)'="" D  Q

 ..NEW ID

 ..S ID=$P(^APCM14OB(IND,0),U,1)

 ..I $P(^APCM14OB(IND,0),U,8)=F S $P(@BQIGREF@(PROV,ID,"CURR"),U,1)=$P($G(@BQIGREF@(PROV,ID,"CURR")),U,1)+VALUE

 ..I $P(^APCM14OB(IND,0),U,9)=F S $P(@BQIGREF@(PROV,ID,"CURR"),U,2)=$P($G(@BQIGREF@(PROV,ID,"CURR")),U,2)+VALUE

 ..I $P(^APCM14OB(IND,0),U,11)=F S $P(@BQIGREF@(PROV,ID,"CURR"),U,3)=VALUE

 ..S $P(@BQIGREF@(PROV,ID,"CURR"),U,4)=$G(APCMVALU)

 .S Y=$P(^DD(9001302.0311,F,0),U,4)

 .S N=$P(Y,";")

 .S P=$P(Y,";",2)

 .S J=$O(^APCMM14C(RPT,11,"B",I,0))

 .I 'J W APCMBOMB Q

 .I VALUE?.N S $P(^APCMM14C(RPT,11,J,N),U,P)=$P($G(^APCMM14C(RPT,11,J,N)),U,P)+VALUE

 .I VALUE'?.N S $P(^APCMM14C(RPT,11,J,N),U,P)=VALUE

 .Q

 Q

SETLIST ;EP

 NEW P,APCMX,APCMO

 Q:APCMTIME'=1

 Q:'$D(APCMINDL(APCMIC))  ;not a selected topic

 S APCMX=0 F  S APCMX=$O(APCMINDL(APCMIC,APCMX)) Q:APCMX'=+APCMX  D

 .X ^APCMM14L(APCMX,12) Q:'$T

 .S APCMINDL(APCMIC,APCMX,APCMP)=$G(APCMINDL(APCMIC,APCMX,APCMP))+1

 .S APCMO=$S(APCMRPTT=2:$P(^APCMM14L(APCMX,0),U,6),1:$P(^APCMM14L(APCMX,0),U,5))

 .S P=$S(APCMRPTT=2:$P(^DIC(4,APCMP,0),U),1:$P(^VA(200,APCMP,0),U))

 .S ^XTMP("APCM1D",APCMJ,APCMH,"LIST",$P(^APCM14OB(APCMIC,0),U,4),APCMIC,APCMO,APCMX,P,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),$$AGE^AUPNPAT(DFN,APCMBDAT),DFN)=$G(APCMVALU)

 Q

H100(R,BD,ED) ;

 NEW ID,C,Y,X,VMED,V

 S C=0

 S ID=$$FMADD^XLFDT(BD,-1)

 F  S ID=$O(^PSRX("AC",ID)) Q:ID'=+ID!(C>100)!(ID>ED)  D

 .S X=0 F  S X=$O(^PSRX("AC",ID,X)) Q:X'=+X!(C>100)  D

 ..Q:$P($G(^PSRX(X,0)),U,4)'=R

 ..Q:$P($G(^PSRX(X,"STA")),"^")=13

 ..;SKIP ER CLINIC OR H VISIT, GET VISIT FROM V MED

 ..S VMED=$P($G(^PSRX(X,999999911)),U,1)

 ..Q:'VMED

 ..S V=$P($G(^AUPNVMED(VMED,0)),U,3)

 ..Q:'V

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

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

 ..Q:$$CLINIC^APCLV(V,"C")=30

 ..S C=C+1

 Q $S(C>100:1,1:"")

VST(R,BD,ED) ;CALCULATE EXCLUSIONS

 NEW SD,A,B,C,G,V,T

 S T=$O(^APCMMUCN("B","INTERIM STAGE 1 2014",0))

 S SD=$$FMADD^XLFDT(BD,-1)

 S SD=SD_".9999"

 S G=""

 F  S SD=$O(^AUPNVSIT("B",SD)) Q:SD'=+SD!($P(SD,".")>ED)!($$GOTALL(G))  D

 .S V=0 F  S V=$O(^AUPNVSIT("B",SD,V)) Q:V'=+V!($$GOTALL(G))  D

 ..S B=0,C=0 F  S B=$O(^AUPNVPRV("AD",V,B)) Q:B'=+B  D

 ...Q:'$D(^AUPNVPRV(B,0))

 ...Q:$P(^AUPNVPRV(B,0),U,1)'=R

 ...Q:$P(^AUPNVPRV(B,0),U,4)'="P"

 ...S C=1

 ..Q:'C  ;not to this provider

 ..S C=$$CLINIC^APCLV(V,"C")

 ..I C=30 Q  ;no ER per Carmen patch 1

 ..I C=77 Q  ;no case management clinic 77 per Chris

 ..I C=76 Q  ;no lab

 ..I C=63 Q  ;no radiology

 ..I C=39 Q  ;no pharmacy

 ..S $P(G,U,1)=1  ;has an office visit ;clinic summary excl

 ..I $$AGE^AUPNPAT($P(^AUPNVSIT(V,0),U,5),$P(BD,"."))>12 S $P(G,U,3)=1  ;SMK STATUS EXCL

 ..I $D(^AUPNVIMM("AD",V)) S $P(G,U,5)=1  ;not an exclusion for imm reg

 Q G

 ;

GOTALL(%) ;EP

 NEW Y

 S Y=$P(%,U,1)+$P(%,U,3)+$P(%,U,5)

 I Y=3 Q 1

 Q 0

VSTH(R,BD,ED,APCMMETH) ;did this HOSPITAL HAVE THESE VISITS

 NEW SD,A,B,C,G,V,T,O,P,Q,E,J,S

 S T=$O(^APCMMUCN("B","INTERIM STAGE 1 2014",0))

 S SD=$$FMADD^XLFDT(BD,-1)

 S SD=SD_".9999"

 S G=""

 F  S SD=$O(^AUPNVSIT("B",SD)) Q:SD'=+SD!($P(SD,".")>ED)!($$GOTALLH(G))  D

 .S V=0 F  S V=$O(^AUPNVSIT("B",SD,V)) Q:V'=+V!($$GOTALLH(G))  D

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

 ..I APCMMETH="E" Q:'$$HOSER^APCM24E6(V,R)

 ..I APCMMETH="O" Q:"OH"'[$P(^AUPNVSIT(V,0),U,7)

 ..S $P(G,U,1)=1

 ..S A=$$AGE^AUPNPAT($P(^AUPNVSIT(V,0),U,5),$P(BD,"."))

 ..I A>12 S $P(G,U,3)=1

 ..I $D(^AUPNVIMM("AD",V)) S $P(G,U,5)=1  ;not an exclusion for imm reg

 ..I $P(^AUPNVSIT(V,0),U,7)="H" S A=$$AGE^AUPNPAT($P(^AUPNVSIT(V,0),U,5),$$VD^APCLV(V)) I A>64 S $P(G,U,7)=1

 Q G

TIUDCEL(%) ;any electronic dc instruction TIU Notes

 NEW A,B,C

 S A=0,B=0 F  S A=$O(^AUPNVNOT("AD",%,A)) Q:A'=+A!(B)  D

 .S C=$$VAL^XBDIQ1(9000010.28,A,.01)

 .I $$UP^XLFSTR(C)="E-COPY DISCHARGE INSTR RECEIVED" S B=1 Q

 .I $$UP^XLFSTR(C)="E-COPY DISCHARGE INSTR NOT RECEIVED" S B=1 Q

 Q B

GOTALLH(%) ;EP

 NEW Y

 S Y=$P(%,U,1)+$P(%,U,2)+$P(%,U,3)+$P(%,U,4)+$P(%,U,5)+$P(%,U,6)+$P(%,U,7)+$P(%,U,8)+$P(%,U,9)

 I Y=9 Q 1

 Q 0

VDT ;EP - ask additional exclusion questions for PEA

 S APCMQ=0

 S APCMY=$O(^APCM14OB("B","S1.020.EP",0))

 Q:'$D(APCMIND(APCMY))  ;measure not being run

 K APCMATTE("S1.020.EP.1")

 ;display exclusion text/narrative

 I $O(^APCM14OB(APCMY,26,0)) D ET

 I APCMPLTY="SEL"!(APCMPLTY="TAX") D  G:APCMIND=1 EIND Q

 .S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,19,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,19,APCMZ,0)

 .S APCMQ=0,APCMIND=0

 .W !!!,"The View, Download, Transmit question above may be addressed as a group or"

 .W !,"by individual provider. Do you want to answer for all selected providers as a"

 .S DIR(0)="Y",DIR("A")="group Y/N",DIR("B")="YES" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S APCMQ=1 Q

 .I 'Y S APCMIND=1 Q

 .W !!,"Do all selected providers included in this report meet the broadband"

 .S DIR(0)="Y",DIR("A")="Exclusion",DIR("B")="YES" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S APCMQ=1 Q

 .I 'Y S APCMIND=1 Q

 .S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP  S APCMATTE("S1.020.EP.1",APCMP)="Yes"

EIND ;ask individually

 S APCMP=0 F  S APCMP=$O(APCMPRV(APCMP)) Q:APCMP'=+APCMP!(APCMQ)  D

 .S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,19,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,19,APCMZ,0)

 .S DIR(0)="Y",DIR("A")="Does "_$E($P(^VA(200,APCMP,0),U,1),1,25)_" meet the broadband exclusion",DIR("B")="YES" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S APCMQ=1 Q

 .S APCMATTE("S1.020.EP.1",APCMP)=$S(Y:"Yes",1:"No")

 Q

ET ;

 W ! S APCMZ=0 F  S APCMZ=$O(^APCM14OB(APCMY,26,APCMZ)) Q:APCMZ'=+APCMZ  W !,^APCM14OB(APCMY,26,APCMZ,0)

 W !

 Q

APCM14E1  ; IHS/CMI/LAB - IHS MU 24 Feb 2014 10:32 AM ; 

 +1       ;;1.0;IHS MU PERFORMANCE REPORTS;**5,6**;MAR 26, 2012;Build 65

 +2       ;

BQI(BQIGREF,APCMPRV) ;PEP-Call from iCare

 +1       ; input

 +2       ; BQIGREF - Global reference

 +3       ; APCMPRV - Array of providers

 +4       ;

PROC      ;EP

 +1        SET APCMBT=$HOROLOG

 +2       ;D JRNL^APCM1UTL

 +3        SET APCMJ=$JOB

           SET APCMH=$HOROLOG

 +4        DO XTMP^APCM1UTL("APCM1D","MU Patient List")

 +5       ;process each patient

 +6       ;first gather up provider exclusions

 +7       ;hospital report doesn't need this stuff for exclusions

           IF APCMRPTT=2

               Begin DoDot:1

 +8                KILL APCMOFFV

 +9       ;SMK STATUS EXCL

                   KILL APCM14ON

 +10      ;IMM EXCL

                   KILL APCMIMME

 +11      ;ADV DIR EXCL

                   KILL APCMHO65

 +12               SET X=APCMFAC

                   SET APCMX=$$VSTH(APCMFAC,APCMBD,APCMED,APCMMETH)

                   Begin DoDot:2

 +13      ;SMOKING STATUS EXCL

                       IF '$PIECE(APCMX,U,3)

                           SET APCM14ON(X,1)=""

 +14                   IF '$PIECE(APCMX,U,1)

                           SET APCMOFFV(X,1)=""

 +15      ;IMM REG

                       IF '$PIECE(APCMX,U,5)

                           SET APCMIMME(X,1)=""

 +16      ;ADV DIR EXCL

                       IF '$PIECE(APCMX,U,7)

                           SET APCMHO65(X,1)=""

                   End DoDot:2

 +17      ;

               End DoDot:1

               GOTO PROC1

 +18       KILL APCM100R

 +19      ;S1.003.EP E-RX EXCL, DRUG FORM EXCL

           SET X=0

           FOR 

               SET X=$ORDER(APCMPRV(X))

               IF X'=+X

                   QUIT 

               IF '$$H100(X,APCMBD,APCMED)

                   SET APCM100R(X,1)=""

 +20       KILL APCMOFFV

 +21       KILL APCM14ON

 +22       KILL APCMIMME

 +23       SET X=0

           FOR 

               SET X=$ORDER(APCMPRV(X))

               IF X'=+X

                   QUIT 

               SET APCMX=$$VST(X,APCMBD,APCMED)

               Begin DoDot:1

 +24      ;SMK STATUS EXCL

                   IF '$PIECE(APCMX,U,3)

                       SET APCM14ON(X,1)=""

 +25      ;CLIN SUM EXCL

                   IF '$PIECE(APCMX,U,1)

                       SET APCMOFFV(X,1)=""

 +26      ;IMM REG EXCL

                   IF '$PIECE(APCMX,U,5)

                       SET APCMIMME(X,1)=""

               End DoDot:1

N1        ;

 +1       ;any patients 0-5 or >64?

 +2        SET APCMN565(1)=1

 +3        SET P=0

           FOR 

               SET P=$ORDER(^DPT(P))

               IF P'=+P!(APCMN565(1)=0)

                   QUIT 

               Begin DoDot:1

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

 +5                IF X

                       IF X'>APCMED

                           QUIT 

 +6       ;born after time period begin date

                   IF $$DOB^AUPNPAT(P)>APCMBD

                       QUIT 

 +7                SET X=$PIECE($GET(^AUPNPAT(P,41,DUZ(2),0)),U,3)

 +8                IF X

                       IF X'>APCMED

                           QUIT 

 +9                SET A=$$AGE^AUPNPAT(P,APCMBD)

 +10               IF A<6

                       SET APCMN565(1)=0

                       QUIT 

 +11               IF A>64

                       SET APCMN565(1)=0

                       QUIT 

               End DoDot:1

 +12      ;

PROC1     ;

 +1        SET DFN=0

           FOR 

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

               IF DFN'=+DFN

                   QUIT 

               Begin DoDot:1

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

                       QUIT 

 +3       ;I DUZ=2793 Q:'$D(^DIBT(4723,1,DFN))

 +4       ;I DUZ=2793 Q:DFN'=5851

 +5                IF $$DEMO^APCLUTL(DFN,$GET(APCMDEMO))

                       QUIT 

 +6                DO PROCCY

               End DoDot:1

N         ;

 +1       ;NOW DO ATTESTATION MEASURES

 +2        DO PROCACY

 +3        SET APCMET=$HOROLOG

 +4        QUIT 

 +5       ;

PROCCY    ;EP - current time period

 +1        KILL ^TMP($JOB)

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

               QUIT 

 +3        IF $PIECE(^DPT(DFN,0),U,2)=""

               QUIT 

 +4        SET APCMEDAT=APCMED

           SET APCMTIME=1

           SET APCMBDAT=APCMBD

           SET APCMGBL="^APCMM14C("

           SET APCMFILN=9001302.0311

 +5        SET APCMAGEB=$$AGE^AUPNPAT(DFN,APCMBDAT)

 +6        SET APCMAGEE=$$AGE^AUPNPAT(DFN,APCMEDAT)

 +7        SET APCMSEX=$PIECE(^DPT(DFN,0),U,2)

 +8       ;had visit to each provider?

 +9        DO CALCIND

 +10       KILL ^TMP($JOB,"A")

 +11       QUIT 

CALCIND   ;

 +1        DO CALCIND^APCM14CI

 +2        QUIT 

PROCACY   ;EP - current time period

 +1        SET APCMEDAT=APCMED

           SET APCMTIME=1

           SET APCMBDAT=APCMBD

           SET APCMGBL="^APCMM14C("

           SET APCMFILN=9001302.0311

 +2        DO CALCINDA^APCM14CI

 +3        QUIT 

S(RPT,IND,VALUE,PROV,RT,T,F,NT) ;EP - set counter

 +1        NEW N,P,Y,J,I,ID

 +2       ;no value to add

           IF VALUE=""

               QUIT 

 +3        IF RT=1

               SET I=PROV_";VA(200,"

 +4        IF RT=2

               SET I=PROV_";AUTTLOC("

 +5        IF T=1

               Begin DoDot:1

 +6                IF $GET(BQIGREF)'=""

                       Begin DoDot:2

 +7                        NEW ID

 +8                        SET ID=$PIECE(^APCM14OB(IND,0),U,1)

 +9                        IF $PIECE(^APCM14OB(IND,0),U,8)=F

                               SET $PIECE(@BQIGREF@(PROV,ID,"CURR"),U,1)=$PIECE($GET(@BQIGREF@(PROV,ID,"CURR")),U,1)+VALUE

 +10                       IF $PIECE(^APCM14OB(IND,0),U,9)=F

                               SET $PIECE(@BQIGREF@(PROV,ID,"CURR"),U,2)=$PIECE($GET(@BQIGREF@(PROV,ID,"CURR")),U,2)+VALUE

 +11                       IF $PIECE(^APCM14OB(IND,0),U,11)=F

                               SET $PIECE(@BQIGREF@(PROV,ID,"CURR"),U,3)=VALUE

 +12                       SET $PIECE(@BQIGREF@(PROV,ID,"CURR"),U,4)=$GET(APCMVALU)

                       End DoDot:2

                       QUIT 

 +13               SET Y=$PIECE(^DD(9001302.0311,F,0),U,4)

 +14               SET N=$PIECE(Y,";")

 +15               SET P=$PIECE(Y,";",2)

 +16               SET J=$ORDER(^APCMM14C(RPT,11,"B",I,0))

 +17               IF 'J

                       WRITE APCMBOMB

                       QUIT 

 +18               IF VALUE?.N

                       SET $PIECE(^APCMM14C(RPT,11,J,N),U,P)=$PIECE($GET(^APCMM14C(RPT,11,J,N)),U,P)+VALUE

 +19               IF VALUE'?.N

                       SET $PIECE(^APCMM14C(RPT,11,J,N),U,P)=VALUE

 +20               QUIT 

               End DoDot:1

               QUIT 

 +21       QUIT 

SETLIST   ;EP

 +1        NEW P,APCMX,APCMO

 +2        IF APCMTIME'=1

               QUIT 

 +3       ;not a selected topic

           IF '$DATA(APCMINDL(APCMIC))

               QUIT 

 +4        SET APCMX=0

           FOR 

               SET APCMX=$ORDER(APCMINDL(APCMIC,APCMX))

               IF APCMX'=+APCMX

                   QUIT 

               Begin DoDot:1

 +5                XECUTE ^APCMM14L(APCMX,12)

                   IF '$TEST

                       QUIT 

 +6                SET APCMINDL(APCMIC,APCMX,APCMP)=$GET(APCMINDL(APCMIC,APCMX,APCMP))+1

 +7                SET APCMO=$SELECT(APCMRPTT=2:$PIECE(^APCMM14L(APCMX,0),U,6),1:$PIECE(^APCMM14L(APCMX,0),U,5))

 +8                SET P=$SELECT(APCMRPTT=2:$PIECE(^DIC(4,APCMP,0),U),1:$PIECE(^VA(200,APCMP,0),U))

 +9               SET ^XTMP("APCM1D",APCMJ,APCMH,"LIST",$PIECE(^APCM14OB(APCMIC,0),U,4),APCMIC,APCMO,APCMX,P,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),$$AGE^AUPNPAT(DFN,APCMBDAT),DFN)

=...

                   ... $GET(APCMVALU)

               End DoDot:1

 +10       QUIT 

H100(R,BD,ED) ;

 +1        NEW ID,C,Y,X,VMED,V

 +2        SET C=0

 +3        SET ID=$$FMADD^XLFDT(BD,-1)

 +4        FOR 

               SET ID=$ORDER(^PSRX("AC",ID))

               IF ID'=+ID!(C>100)!(ID>ED)

                   QUIT 

               Begin DoDot:1

 +5                SET X=0

                   FOR 

                       SET X=$ORDER(^PSRX("AC",ID,X))

                       IF X'=+X!(C>100)

                           QUIT 

                       Begin DoDot:2

 +6                        IF $PIECE($GET(^PSRX(X,0)),U,4)'=R

                               QUIT 

 +7                        IF $PIECE($GET(^PSRX(X,"STA")),"^")=13

                               QUIT 

 +8       ;SKIP ER CLINIC OR H VISIT, GET VISIT FROM V MED

 +9                        SET VMED=$PIECE($GET(^PSRX(X,999999911)),U,1)

 +10                       IF 'VMED

                               QUIT 

 +11                       SET V=$PIECE($GET(^AUPNVMED(VMED,0)),U,3)

 +12                       IF 'V

                               QUIT 

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

                               QUIT 

 +14                       IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

                               QUIT 

 +15                       IF $$CLINIC^APCLV(V,"C")=30

                               QUIT 

 +16                       SET C=C+1

                       End DoDot:2

               End DoDot:1

 +17       QUIT $SELECT(C>100:1,1:"")

VST(R,BD,ED) ;CALCULATE EXCLUSIONS

 +1        NEW SD,A,B,C,G,V,T

 +2        SET T=$ORDER(^APCMMUCN("B","INTERIM STAGE 1 2014",0))

 +3        SET SD=$$FMADD^XLFDT(BD,-1)

 +4        SET SD=SD_".9999"

 +5        SET G=""

 +6        FOR 

               SET SD=$ORDER(^AUPNVSIT("B",SD))

               IF SD'=+SD!($PIECE(SD,".")>ED)!($$GOTALL(G))

                   QUIT 

               Begin DoDot:1

 +7                SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("B",SD,V))

                       IF V'=+V!($$GOTALL(G))

                           QUIT 

                       Begin DoDot:2

 +8                        SET B=0

                           SET C=0

                           FOR 

                               SET B=$ORDER(^AUPNVPRV("AD",V,B))

                               IF B'=+B

                                   QUIT 

                               Begin DoDot:3

 +9                                IF '$DATA(^AUPNVPRV(B,0))

                                       QUIT 

 +10                               IF $PIECE(^AUPNVPRV(B,0),U,1)'=R

                                       QUIT 

 +11                               IF $PIECE(^AUPNVPRV(B,0),U,4)'="P"

                                       QUIT 

 +12                               SET C=1

                               End DoDot:3

 +13      ;not to this provider

                           IF 'C

                               QUIT 

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

 +15      ;no ER per Carmen patch 1

                           IF C=30

                               QUIT 

 +16      ;no case management clinic 77 per Chris

                           IF C=77

                               QUIT 

 +17      ;no lab

                           IF C=76

                               QUIT 

 +18      ;no radiology

                           IF C=63

                               QUIT 

 +19      ;no pharmacy

                           IF C=39

                               QUIT 

 +20      ;has an office visit ;clinic summary excl

                           SET $PIECE(G,U,1)=1

 +21      ;SMK STATUS EXCL

                           IF $$AGE^AUPNPAT($PIECE(^AUPNVSIT(V,0),U,5),$PIECE(BD,"."))>12

                               SET $PIECE(G,U,3)=1

 +22      ;not an exclusion for imm reg

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

                               SET $PIECE(G,U,5)=1

                       End DoDot:2

               End DoDot:1

 +23       QUIT G

 +24      ;

GOTALL(%) ;EP

 +1        NEW Y

 +2        SET Y=$PIECE(%,U,1)+$PIECE(%,U,3)+$PIECE(%,U,5)

 +3        IF Y=3

               QUIT 1

 +4        QUIT 0

VSTH(R,BD,ED,APCMMETH) ;did this HOSPITAL HAVE THESE VISITS

 +1        NEW SD,A,B,C,G,V,T,O,P,Q,E,J,S

 +2        SET T=$ORDER(^APCMMUCN("B","INTERIM STAGE 1 2014",0))

 +3        SET SD=$$FMADD^XLFDT(BD,-1)

 +4        SET SD=SD_".9999"

 +5        SET G=""

 +6        FOR 

               SET SD=$ORDER(^AUPNVSIT("B",SD))

               IF SD'=+SD!($PIECE(SD,".")>ED)!($$GOTALLH(G))

                   QUIT 

               Begin DoDot:1

 +7                SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("B",SD,V))

                       IF V'=+V!($$GOTALLH(G))

                           QUIT 

                       Begin DoDot:2

 +8                        IF $PIECE(^AUPNVSIT(V,0),U,6)'=R

                               QUIT 

 +9                        IF APCMMETH="E"

                               IF '$$HOSER^APCM24E6(V,R)

                                   QUIT 

 +10                       IF APCMMETH="O"

                               IF "OH"'[$PIECE(^AUPNVSIT(V,0),U,7)

                                   QUIT 

 +11                       SET $PIECE(G,U,1)=1

 +12                       SET A=$$AGE^AUPNPAT($PIECE(^AUPNVSIT(V,0),U,5),$PIECE(BD,"."))

 +13                       IF A>12

                               SET $PIECE(G,U,3)=1

 +14      ;not an exclusion for imm reg

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

                               SET $PIECE(G,U,5)=1

 +15                       IF $PIECE(^AUPNVSIT(V,0),U,7)="H"

                               SET A=$$AGE^AUPNPAT($PIECE(^AUPNVSIT(V,0),U,5),$$VD^APCLV(V))

                               IF A>64

                                   SET $PIECE(G,U,7)=1

                       End DoDot:2

               End DoDot:1

 +16       QUIT G

TIUDCEL(%) ;any electronic dc instruction TIU Notes

 +1        NEW A,B,C

 +2        SET A=0

           SET B=0

           FOR 

               SET A=$ORDER(^AUPNVNOT("AD",%,A))

               IF A'=+A!(B)

                   QUIT 

               Begin DoDot:1

 +3                SET C=$$VAL^XBDIQ1(9000010.28,A,.01)