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
Q
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
Q
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)=""
Q
PRN ;EP
S APCLPG=0 D HEAD
K APCLQUIT
D PRINT
;
DONE ;
K ^XTMP("APCLM1",APCLJOB,APCLBTH),APCLJOB,APCLBTH
D DONE^APCLOSUT
Q
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
Q
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
Q
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)," ","-"),!
Q
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
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
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
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
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
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
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 ;;
