Routine: APCLM1

APCLM1 ; IHS/CMI/LAB - ADULT IMMUNIZATION NEEDS ;

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

 ;IHS/CMI/LAB - patch 4 for new imm package and 4 digit year display/Y2K

START ;

 W:$D(IOF) @IOF

 W !!?12,"**********   ADULT IMMUNIZATION NEEDS   **********"

ST ;

 W !!,"This report displays the most recent Td, Pneumococcal, & Influenza Vaccinations",!,"for Adults considered as 'High Risk.'  Utilizing QMan, development of a",!

 W "Cohort (Template) of Patients is required prior to running this report.",!!

 W "Development of the Cohort of High Risk Adults usually consists of finding",!,"Living Patients who are over Age 65 OR who have one or more specific",!,"chronic diseases.",!!

 W "Feel free to contact the Help Desk for",!,"assistance in creating your Cohort.",!!

 W "Note:  Patients with Inactive charts will not appear on this report even",!,"if there were a member of the cohort (template).",!! ;IHS/CMI/LAB

 S DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR

 Q:Y=-1

 S APCLSEAT=+Y

ZIS ;call to XBDBQUE

 S XBRP="PRN^APCLM1",XBRC="PROC^APCLM1",XBRX="XIT^APCLM1",XBNS="APCL"

 D ^XBDBQUE

 D XIT

XIT ;

 K APCLQUIT,APCLPG,DFN,APCLSEAT,APCL,APCLER,APCLX,APCLCOM,APCLNAME

 D KILL^AUPNPAT

 K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M

PROC ;

 S APCLJOB=$J,APCLBTH=$H

 D XTMP^APCLOSUT("APCLM1","PCC IMMUNIZATION REPORT 1")

 S X=0 F  S X=$O(^DIBT(APCLSEAT,1,X)) Q:X'=+X  D

 .Q:$P($G(^AUPNPAT(X,41,DUZ(2),0)),U,5)]""  ;IHS/CMI/LAB - exlude inactive patients

 .S Y=$$COMMRES^AUPNPAT(X,"E") S:Y=""!(Y=-1) Y="?? - UNKNOWN" S ^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",Y,$P(^DPT(X,0),U),X)=""

PRN ;EP

 S APCLPG=0 D HEAD

 K APCLQUIT

 D PRINT

DONE ;

 K ^XTMP("APCLM1",APCLJOB,APCLBTH),APCLJOB,APCLBTH

 D DONE^APCLOSUT

PRINT ;

 S APCLCOM="" F  S APCLCOM=$O(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM)) Q:APCLCOM=""!($D(APCLQUIT))  D

 .S APCLNAME="" F  S APCLNAME=$O(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM,APCLNAME)) Q:APCLNAME=""!($D(APCLQUIT))  D

 ..S DFN=0 F  S DFN=$O(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM,APCLNAME,DFN)) Q:DFN'=+DFN!($D(APCLQUIT))  D PRINT1

BI() ;IHS/CMI/LAB - new subroutine patch 4

 Q $S($O(^AUTTIMM(0))>100:1,1:0)

 ;IHS/CMI/LAB - end new subroutine patch 4

PRINT1 ;

 I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)

 W !,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?30,$E($$COMMRES^AUPNPAT(DFN,"E"),1,12),?44,$$AGE^AUPNPAT(DFN,DT)

TD ;

 S X=$$LASTTD(DFN)

 ;K APCL

 ;S APCLER=$$START1^APCLDF(DFN_"^LAST IMM "_$S($$BI:9,1:"02"),"APCL(") ;IHS/CMI/LAB - patch 4 new imm 1/5/99

 ;begin Y2K

 ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) W ?50,X ;Y2000

 S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) W ?48,X ;Y2000

 ;end Y2K

FLU ;

 S X=$$LASTFLU(DFN)

 ;K APCL

 ;S APCLX=DFN_"^LAST IMM "_$S($$BI:88,1:12),APCLER=$$START1^APCLDF(APCLX,"APCL(") ;IHS/CMI/LAB - patch 4 new imm 1/5/1999

 ;begin Y2K

 ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) W ?60,X ;Y2000

 S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) W ?59,X ;Y2000

 ;end Y2K

PNEUMOVX ;

 S X=$$LASTPN(DFN)

 ;K APCL

 ;S APCLER=$$START1^APCLDF(DFN_"^LAST IMM "_$S($$BI:33,1:19),"APCL(") ;IHS/CMI/LAB - patch 4 - new imm display

 ;begin Y2K

 ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) W ?70,X ;Y2000

 S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) W ?70,X ;Y2000

 ;end Y2K

HEAD I 'APCLPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q

HEAD1 ;

 W:$D(IOF) @IOF S APCLPG=APCLPG+1

 W !?3,$P(^DIC(4,DUZ(2),0),U),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!

 W ?18,"********  ADULT IMMUNIZATION NEEDS  ********",!

 W !?22,$E($P(^DIC(4,DUZ(2),0),U),1,6),?70,"LAST"

 W !,"PATIENT NAME",?22,"NUMBER",?30,"COMMUNITY",?44,"AGE",?50,"LAST Td",?60,"LAST FLU",?70,"PNEUMOVAX"

 W !,$TR($J("",80)," ","-"),!

LASTFLU(P) ;EP

 NEW X,E,B,%DT,Y,TDD,D,APCLY

 K TDD

 I '$$BI D LASTFLO

 I $$BI D LASTFLN

 ;now check cpt codes

 F %=1:1 S T=$T(FLUCPTS+%) Q:$P(T,";;",2)=""  S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""

 K APCLY S %=P_"^LAST DX V04.8",E=$$START1^APCLDF(%,"APCLY(")

 I $D(APCLY(1)) S TDD(9999999-$P(APCLY(1),U))=""

 K APCLY S %=P_"^LAST DX V04.81",E=$$START1^APCLDF(%,"APCLY(")

 I $D(APCLY(1)) S TDD(9999999-$P(APCLY(1),U))=""

 K APCLY S %=P_"^LAST DX V06.6",E=$$START1^APCLDF(%,"APCLY(")

 I $D(APCLY(1)) S TDD(9999999-$P(APCLY(1),U))=""

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

 I $D(APCLY(1)) S TDD(9999999-$P(APCLY(1),U))=""

 I '$D(TDD) Q ""

 Q 9999999-($O(TDD(0)))

LASTFLN ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B=15 S TDD(9999999-D)="" Q

 .I B=16 S TDD(9999999-D)="" Q

 .I B=88 S TDD(9999999-D)="" Q

 .I B=111 S TDD(9999999-D)="" Q

;;

LASTFLO ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B=12 S TDD(9999999-D)="" Q

LASTTD(P) ;EP

 NEW X,E,B,%DT,Y,TDD,D,APCLY

 K TDD

 I '$$BI D LASTTDO

 I $$BI D LASTTDN

 ;now check cpt codes

 F %=1:1 S T=$T(TDCPTS+%) Q:$P(T,";;",2)=""  S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""

 I '$D(TDD) Q ""

 Q 9999999-$O(TDD(0))

LASTTDN ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B=1 S TDD(9999999-D)="" Q

 .I B=9 S TDD(9999999-D)="" Q

 .I B=20 S TDD(9999999-D)="" Q

 .I B=22 S TDD(9999999-D)="" Q

 .I B=28 S TDD(9999999-D)="" Q

 .I B=35 S TDD(9999999-D)="" Q

 .I B=50 S TDD(9999999-D)="" Q

 .I B=106 S TDD(9999999-D)="" Q

 .I B=107 S TDD(9999999-D)="" Q

 .I B=110 S TDD(9999999-D)="" Q

;;

LASTTDO ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B="04" S TDD(9999999-D)="" Q

 .I B=42 S TDD(9999999-D)="" Q

 .I B=34 S TDD(9999999-D)="" Q

 .I B="03" S TDD(9999999-D)="" Q

 .I B="02" S TDD(9999999-D)="" Q

LASTPN(P) ;EP

 NEW X,E,B,%DT,Y,TDD,D,APCLY

 K TDD

 I '$$BI D LASTPNO

 I $$BI D LASTPNN

 ;now check cpt codes

 F %=1:1 S T=$T(PNCPTS+%) Q:$P(T,";;",2)=""  S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""

 I '$D(TDD) Q ""

 Q 9999999-($O(TDD(0)))

LASTPNN ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B=33 S TDD(9999999-D)="" Q

 .I B=100 S TDD(9999999-D)="" Q

 .I B=109 S TDD(9999999-D)="" Q

;;

LASTPNO ;

 S X=0 F  S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X  D

 .S B=$P(^AUPNVIMM(X,0),U) Q:'B

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

 .S B=$P(^AUTTIMM(B,0),U,3)

 .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D

 .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")

 .I B=19 S TDD(9999999-D)="" Q

TDCPTS ;;

 ;;90701

 ;;90718

 ;;90700

 ;;90720

 ;;90702

 ;;90703

 ;;90721

 ;;90723

;;

PAPCPTS ;;

 ;;88141

 ;;88142

 ;;88143

 ;;88144

 ;;88145

 ;;88146

 ;;88147

 ;;88148

 ;;88150

 ;;88152

 ;;88153

 ;;88154

 ;;88155

 ;;88156

 ;;88157

 ;;88158

 ;;88164

 ;;88165

 ;;88166

 ;;88167

;;

FLUCPTS ;;

 ;;90657

 ;;90658

 ;;90655

 ;;90724

 ;;90711

 ;;90659

 ;;90660

;;

SIGCPTS ;;

 ;;45330

 ;;45331

 ;;45332

 ;;45333

 ;;45334

 ;;45336

 ;;45337

 ;;45338

 ;;45339

 ;;45341

 ;;45342

 ;;45345

;;

BECPTS ;;

 ;;74270

 ;;74275

 ;;74280

;;

COLOCPTS ;;

 ;;45355

 ;;45360

 ;;45361

 ;;45362

 ;;45363

 ;;45364

 ;;45365

 ;;45366

 ;;45367

 ;;45368

 ;;45369

 ;;45370

 ;;45371

 ;;45372

 ;;45378

 ;;45379

 ;;45380

 ;;45382

 ;;45383

 ;;45384

 ;;45385

 ;;45387

;;

PNCPTS ;;

 ;;90732

 ;;90669

;;

APCLM1    ; IHS/CMI/LAB - ADULT IMMUNIZATION NEEDS ;

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

 +2       ;IHS/CMI/LAB - patch 4 for new imm package and 4 digit year display/Y2K

 +3       ;

 +4       ;

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !!?12,"**********   ADULT IMMUNIZATION NEEDS   **********"

ST        ;

 +1        WRITE !!,"This report displays the most recent Td, Pneumococcal, & Influenza Vaccinations",!,"for Adults considered as 'High Risk.'  Utilizing QMan, development of a",!

 +2        WRITE "Cohort (Template) of Patients is required prior to running this report.",!!

 +3        WRITE "Development of the Cohort of High Risk Adults usually consists of finding",!,"Living Patients who are over Age 65 OR who have one or more specific",!,"chronic diseases.",!!

 +4        WRITE "Feel free to contact the Help Desk for",!,"assistance in creating your Cohort.",!!

 +5       ;IHS/CMI/LAB

           WRITE "Note:  Patients with Inactive charts will not appear on this report even",!,"if there were a member of the cohort (template).",!!

 +6       ;

 +7        SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)"

           SET DIC="^DIBT("

           SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA,DR,DICR

 +8        IF Y=-1

               QUIT

 +9        SET APCLSEAT=+Y

ZIS       ;call to XBDBQUE

 +1        SET XBRP="PRN^APCLM1"

           SET XBRC="PROC^APCLM1"

           SET XBRX="XIT^APCLM1"

           SET XBNS="APCL"

 +2        DO ^XBDBQUE

 +3        DO XIT

 +4        QUIT

XIT       ;

 +1        KILL APCLQUIT,APCLPG,DFN,APCLSEAT,APCL,APCLER,APCLX,APCLCOM,APCLNAME

 +2        DO KILL^AUPNPAT

 +3        KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M

 +4        QUIT

PROC      ;

 +1        SET APCLJOB=$JOB

           SET APCLBTH=$HOROLOG

 +2        DO XTMP^APCLOSUT("APCLM1","PCC IMMUNIZATION REPORT 1")

 +3        SET X=0

FOR

               SET X=$ORDER(^DIBT(APCLSEAT,1,X))

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +4       ;IHS/CMI/LAB - exlude inactive patients

                   IF $PIECE($GET(^AUPNPAT(X,41,DUZ(2),0)),U,5)]""

                       QUIT

 +5                SET Y=$$COMMRES^AUPNPAT(X,"E")

                   IF Y=""!(Y=-1)

                       SET Y="?? - UNKNOWN"

                   SET ^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",Y,$PIECE(^DPT(X,0),U),X)=""

               End DoDot:1

 +6        QUIT

PRN       ;EP

 +1        SET APCLPG=0

           DO HEAD

 +2        KILL APCLQUIT

 +3        DO PRINT

 +4       ;

DONE      ;

 +1        KILL ^XTMP("APCLM1",APCLJOB,APCLBTH),APCLJOB,APCLBTH

 +2        DO DONE^APCLOSUT

 +3        QUIT

PRINT     ;

 +1        SET APCLCOM=""

FOR

               SET APCLCOM=$ORDER(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM))

               IF APCLCOM=""!($DATA(APCLQUIT))

                   QUIT

               Begin DoDot:1

 +2                SET APCLNAME=""

FOR

                       SET APCLNAME=$ORDER(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM,APCLNAME))

                       IF APCLNAME=""!($DATA(APCLQUIT))

                           QUIT

                       Begin DoDot:2

 +3                        SET DFN=0

FOR

                               SET DFN=$ORDER(^XTMP("APCLM1",APCLJOB,APCLBTH,"PATS",APCLCOM,APCLNAME,DFN))

                               IF DFN'=+DFN!($DATA(APCLQUIT))

                                   QUIT

                               DO PRINT1

                       End DoDot:2

               End DoDot:1

 +4        QUIT

BI()      ;IHS/CMI/LAB - new subroutine patch 4

 +1        QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)

 +2       ;IHS/CMI/LAB - end new subroutine patch 4

PRINT1    ;

 +1        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(APCLQUIT)

                   QUIT

 +2        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?30,$EXTRACT($$COMMRES^AUPNPAT(DFN,"E"),1,12),?44,$$AGE^AUPNPAT(DFN,DT)

TD        ;

 +1        SET X=$$LASTTD(DFN)

 +2       ;K APCL

 +3       ;S APCLER=$$START1^APCLDF(DFN_"^LAST IMM "_$S($$BI:9,1:"02"),"APCL(") ;IHS/CMI/LAB - patch 4 new imm 1/5/99

 +4       ;begin Y2K

 +5       ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) W ?50,X ;Y2000

 +6       ;Y2000

           IF X]""

               SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))

           WRITE ?48,X

 +7       ;end Y2K

FLU       ;

 +1        SET X=$$LASTFLU(DFN)

 +2       ;K APCL

 +3       ;S APCLX=DFN_"^LAST IMM "_$S($$BI:88,1:12),APCLER=$$START1^APCLDF(APCLX,"APCL(") ;IHS/CMI/LAB - patch 4 new imm 1/5/1999

 +4       ;begin Y2K

 +5       ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) W ?60,X ;Y2000

 +6       ;Y2000

           IF X]""

               SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))

           WRITE ?59,X

 +7       ;end Y2K

PNEUMOVX  ;

 +1        SET X=$$LASTPN(DFN)

 +2       ;K APCL

 +3       ;S APCLER=$$START1^APCLDF(DFN_"^LAST IMM "_$S($$BI:33,1:19),"APCL(") ;IHS/CMI/LAB - patch 4 - new imm display

 +4       ;begin Y2K

 +5       ;S X=$P($G(APCL(1)),U) S:X]"" X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) W ?70,X ;Y2000

 +6       ;Y2000

           IF X]""

               SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))

           WRITE ?70,X

 +7       ;end Y2K

 +8        QUIT

HEAD       IF 'APCLPG

               GOTO HEAD1

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLQUIT=""

                       QUIT

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCLPG=APCLPG+1

 +2        WRITE !?3,$PIECE(^DIC(4,DUZ(2),0),U),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!

 +3        WRITE ?18,"********  ADULT IMMUNIZATION NEEDS  ********",!

 +4        WRITE !?22,$EXTRACT($PIECE(^DIC(4,DUZ(2),0),U),1,6),?70,"LAST"

 +5        WRITE !,"PATIENT NAME",?22,"NUMBER",?30,"COMMUNITY",?44,"AGE",?50,"LAST Td",?60,"LAST FLU",?70,"PNEUMOVAX"

 +6        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-"),!

 +7        QUIT

LASTFLU(P) ;EP

 +1        NEW X,E,B,%DT,Y,TDD,D,APCLY

 +2        KILL TDD

 +3        IF '$$BI

               DO LASTFLO

 +4        IF $$BI

               DO LASTFLN

 +5       ;now check cpt codes

 +6        FOR %=1:1

               SET T=$TEXT(FLUCPTS+%)

               IF $PIECE(T,";;",2)=""

                   QUIT

               SET T=$PIECE(T,";;",2)

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

               IF T

                   SET X=$ORDER(^AUPNVCPT("AA",P,T,0))

                   IF X]""

                       SET TDD(X)=""

 +7        KILL APCLY

           SET %=P_"^LAST DX V04.8"

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

 +8        IF $DATA(APCLY(1))

               SET TDD(9999999-$PIECE(APCLY(1),U))=""

 +9        KILL APCLY

           SET %=P_"^LAST DX V04.81"

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

 +10       IF $DATA(APCLY(1))

               SET TDD(9999999-$PIECE(APCLY(1),U))=""

 +11       KILL APCLY

           SET %=P_"^LAST DX V06.6"

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

 +12       IF $DATA(APCLY(1))

               SET TDD(9999999-$PIECE(APCLY(1),U))=""

 +13       KILL APCLY

           SET %=P_"^LAST PROCEDURE 99.52"

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

 +14       IF $DATA(APCLY(1))

               SET TDD(9999999-$PIECE(APCLY(1),U))=""

 +15       IF '$DATA(TDD)

               QUIT ""

 +16       QUIT 9999999-($ORDER(TDD(0)))

 +17      ;

LASTFLN   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B=15

                       SET TDD(9999999-D)=""

                       QUIT

 +8                IF B=16

                       SET TDD(9999999-D)=""

                       QUIT

 +9                IF B=88

                       SET TDD(9999999-D)=""

                       QUIT

 +10               IF B=111

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +11       QUIT

 +12      ;;

LASTFLO   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B=12

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +8        QUIT

LASTTD(P) ;EP

 +1        NEW X,E,B,%DT,Y,TDD,D,APCLY

 +2        KILL TDD

 +3        IF '$$BI

               DO LASTTDO

 +4        IF $$BI

               DO LASTTDN

 +5       ;now check cpt codes

 +6        FOR %=1:1

               SET T=$TEXT(TDCPTS+%)

               IF $PIECE(T,";;",2)=""

                   QUIT

               SET T=$PIECE(T,";;",2)

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

               IF T

                   SET X=$ORDER(^AUPNVCPT("AA",P,T,0))

                   IF X]""

                       SET TDD(X)=""

 +7        IF '$DATA(TDD)

               QUIT ""

 +8        QUIT 9999999-$ORDER(TDD(0))

LASTTDN   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B=1

                       SET TDD(9999999-D)=""

                       QUIT

 +8                IF B=9

                       SET TDD(9999999-D)=""

                       QUIT

 +9                IF B=20

                       SET TDD(9999999-D)=""

                       QUIT

 +10               IF B=22

                       SET TDD(9999999-D)=""

                       QUIT

 +11               IF B=28

                       SET TDD(9999999-D)=""

                       QUIT

 +12               IF B=35

                       SET TDD(9999999-D)=""

                       QUIT

 +13               IF B=50

                       SET TDD(9999999-D)=""

                       QUIT

 +14               IF B=106

                       SET TDD(9999999-D)=""

                       QUIT

 +15               IF B=107

                       SET TDD(9999999-D)=""

                       QUIT

 +16               IF B=110

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +17       QUIT

 +18      ;;

LASTTDO   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B="04"

                       SET TDD(9999999-D)=""

                       QUIT

 +8                IF B=42

                       SET TDD(9999999-D)=""

                       QUIT

 +9                IF B=34

                       SET TDD(9999999-D)=""

                       QUIT

 +10               IF B="03"

                       SET TDD(9999999-D)=""

                       QUIT

 +11               IF B="02"

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +12       QUIT

LASTPN(P) ;EP

 +1        NEW X,E,B,%DT,Y,TDD,D,APCLY

 +2        KILL TDD

 +3        IF '$$BI

               DO LASTPNO

 +4        IF $$BI

               DO LASTPNN

 +5       ;now check cpt codes

 +6        FOR %=1:1

               SET T=$TEXT(PNCPTS+%)

               IF $PIECE(T,";;",2)=""

                   QUIT

               SET T=$PIECE(T,";;",2)

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

               IF T

                   SET X=$ORDER(^AUPNVCPT("AA",P,T,0))

                   IF X]""

                       SET TDD(X)=""

 +7        IF '$DATA(TDD)

               QUIT ""

 +8        QUIT 9999999-($ORDER(TDD(0)))

 +9       ;

LASTPNN   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B=33

                       SET TDD(9999999-D)=""

                       QUIT

 +8                IF B=100

                       SET TDD(9999999-D)=""

                       QUIT

 +9                IF B=109

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +10       QUIT

 +11      ;;

LASTPNO   ;

 +1        SET X=0

FOR

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

               IF X'=+X

                   QUIT

               Begin DoDot:1

 +2                SET B=$PIECE(^AUPNVIMM(X,0),U)

                   IF 'B

                       QUIT

 +3                IF '$DATA(^AUTTIMM(B,0))

                       QUIT

 +4                SET B=$PIECE(^AUTTIMM(B,0),U,3)

 +5                SET D=$PIECE(^AUPNVIMM(X,0),U,3)

                   IF 'D

                       QUIT

 +6                SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")

 +7                IF B=19

                       SET TDD(9999999-D)=""

                       QUIT

               End DoDot:1

 +8        QUIT

TDCPTS    ;;

 +1       ;;90701

 +2       ;;90718

 +3       ;;90700

 +4       ;;90720

 +5       ;;90702

 +6       ;;90703

 +7       ;;90721

 +8       ;;90723

 +9       ;;

PAPCPTS   ;;

 +1       ;;88141

 +2       ;;88142

 +3       ;;88143

 +4       ;;88144

 +5       ;;88145

 +6       ;;88146

 +7       ;;88147

 +8       ;;88148

 +9       ;;88150

 +10      ;;88152

 +11      ;;88153

 +12      ;;88154

 +13      ;;88155

 +14      ;;88156

 +15      ;;88157

 +16      ;;88158

 +17      ;;88164

 +18      ;;88165

 +19      ;;88166

 +20      ;;88167

 +21      ;;

FLUCPTS   ;;

 +1       ;;90657

 +2       ;;90658

 +3       ;;90655

 +4       ;;90724

 +5       ;;90711

 +6       ;;90659

 +7       ;;90660

 +8       ;;

SIGCPTS   ;;

 +1       ;;45330

 +2       ;;45331

 +3       ;;45332

 +4       ;;45333

 +5       ;;45334

 +6       ;;45336

 +7       ;;45337

 +8       ;;45338

 +9       ;;45339

 +10      ;;45341

 +11      ;;45342

 +12      ;;45345

 +13      ;;

BECPTS    ;;

 +1       ;;74270

 +2       ;;74275

 +3       ;;74280

 +4       ;;

COLOCPTS  ;;

 +1       ;;45355

 +2       ;;45360

 +3       ;;45361

 +4       ;;45362

 +5       ;;45363

 +6       ;;45364

 +7       ;;45365

 +8       ;;45366

 +9       ;;45367

 +10      ;;45368

 +11      ;;45369

 +12      ;;45370

 +13      ;;45371

 +14      ;;45372

 +15      ;;45378

 +16      ;;45379

 +17      ;;45380

 +18      ;;45382

 +19      ;;45383

 +20      ;;45384

 +21      ;;45385

 +22      ;;45387

 +23      ;;

PNCPTS    ;;

 +1       ;;90732

 +2       ;;90669

 +3       ;;

APCLM1.m