CIMGAGP3 ; CMI/TUCSON/LAB - aberdeen area GPRA ; [ 03/13/00 8:58 PM ]
;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000
;
;
PHN ;
S X=$$PHNV(DFN,CIMBDATE,CIMEDATE,CIMHOME)
I $P(X,U) D S(CIMRPT,$S(CIMTIME:19,1:20),25,1)
I $P(X,U,2) D S(CIMRPT,$S(CIMTIME:19,1:20),26,1)
D S(CIMRPT,$S(CIMTIME:19,1:20),18,$P(X,U))
D S(CIMRPT,$S(CIMTIME:19,1:20),19,$P(X,U,2))
FLUPNEU ;
S CIMAGE=$$AGE^AUPNPAT(DFN,CIMBDATE)
G:CIMAGE<65 SMOKE
D S(CIMRPT,$S(CIMTIME:19,1:20),20,1)
S V=$$PNEU(DFN,CIMEDATE)
I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),21,1)
I $D(CIMLIST(14)),CIMTIME S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",14,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)=V
S V=$$FLU(DFN,CIMEDATE)
I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),22,1)
I $D(CIMLIST(15)),CIMTIME S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",15,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)=V
SMOKE ;
S X=$$TOBACCO(DFN,CIMEDATE)
I X]"",$E(X)'=4 D S(CIMRPT,$S(CIMTIME:22,1:23),10,1)
I $E(X)=1,$D(CIMLIST(16)),CIMTIME S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",16,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),CIMAGE,DFN)=$E($P(X," ",2,99),1,22)
I $E(X)=1 D S(CIMRPT,$S(CIMTIME:22,1:23),1,X)
S CIMAGEP=$S(CIMAGE=0:2,CIMAGE>0&(CIMAGE<5):3,CIMAGE>4&(CIMAGE<15):4,CIMAGE>14&(CIMAGE<20):5,CIMAGE>19&(CIMAGE<25):6,CIMAGE>24&(CIMAGE<45):7,CIMAGE>44&(CIMAGE<65):8,CIMAGE>64:9,1:BBBBB)
I $E(X)=1 D S(CIMRPT,$S(CIMTIME:22,1:23),CIMAGEP,X) ;set numerator for 1/1 prevalance age piece
INJ20 ;any visit with E code
S CIMNODE=$S(CIMTIME:24,1:25)
;$o THRU injuries
S S=$$FMADD^XLFDT(CIMEDATE,1)
S E=9999999-CIMBDATE,B=9999999-S
F S B=$O(^AUPNVPOV("AA",DFN,B)) Q:B'=+B!(B>E) D
.S V=0 F S V=$O(^AUPNVPOV("AA",DFN,B,V)) Q:V'=+V D
..S Z=$P(^AUPNVPOV(V,0),U,3) Q:'$D(^AUPNVSIT(Z,0))
..S P=$P(^AUPNVPOV(V,0),U),I=$P(^ICD9(P,0),U),D=$P(^ICD9(P,0),U,3)
..Q:I<800
..Q:I>996
..Q:$E(I,1,3)=816
..Q:$E(I,1,3)=826
..Q:$E(I,1,3)=834
..Q:I>839.99&(I<846)
..Q:$E(I,1,3)=848
..Q:$E(I,1,3)>904&($E(I,1,3)<925)
..Q:$E(I,1,3)>930&($E(I,1,3)<940)
..Q:$E(I,1,3)>957&($E(I,1,3)<961)
..Q:$E(I,1,3)>977&($E(I,1,3)<981)
..D S(CIMRPT,$S(CIMTIME:22,1:23),11,1) ;total number of injury diagnoses
..S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"INJURIES",$P(^DPT(DFN,0),U),DFN,$P(^AUPNVPOV(V,0),U,3),V)=""
..I '$D(^CIMAGP(CIMRPT,CIMNODE,"B",I)) D
...S:CIMTIME CIMINJC=CIMINJC+1 S:'CIMTIME CIMINJP=CIMINJP+1 S ^CIMAGP(CIMRPT,CIMNODE,$S(CIMTIME:CIMINJC,1:CIMINJP),0)=I,^CIMAGP(CIMRPT,CIMNODE,"B",I,$S(CIMTIME:CIMINJC,1:CIMINJP))=""
...S ^CIMAGP(CIMRPT,$S(CIMTIME:24,1:25),0)="^"_$S(CIMTIME:19255.24,1:19255.25)_"^"_$S(CIMTIME:CIMINJC,1:CIMINJP)_"^"_$S(CIMTIME:CIMINJC,1:CIMINJP)
..S X=$O(^CIMAGP(CIMRPT,CIMNODE,"B",I,0)),$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,2)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,2)+1,$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,3)=D D
L ...S T=$P(^AUPNVSIT(Z,0),U,3),S=$P(^AUPNVSIT(Z,0),U,7)
...I T="C",S="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)+1 Q
...I T="C",S'="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)+1 Q
...I "OV"'[T,S="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)+1 Q
...I "OV"'[T,"AORSI"[S S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)+1 Q
..;alcohol related
..S A=$P(^AUPNVPOV(V,0),U,7) I A=2 S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,9)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,9)+1
..;e code tally
..S K=$P(^AUPNVPOV(V,0),U,9)
..Q:K=""
..S EC=$P(^ICD9(K,0),U),M=$P(^ICD9(K,0),U,3)
..I '$D(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC)) D
...;get next ien
...S (%,%1)=0 F S %=$O(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,%)) Q:%'=+% S %1=%
...S CIMEN=%1+1
...S ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,CIMEN,0)=EC,^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC,CIMEN)=""
...S ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,0)="^"_$S(CIMTIME:19255.2424,1:19255.2525)_"^"_CIMEN_"^"_CIMEN
..S Y=$O(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC,0)),$P(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,2)=$P(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,2)+1,$P(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,3)=M
Q
S(R,N,P,V) ;
I 'R Q
S $P(^CIMAGP(R,N),U,P)=$P($G(^CIMAGP(R,N)),U,P)+V
Q
;
TOBACCO(P,EDATE) ;EP
I '$G(P) Q ""
NEW APCLTOB,APCL,X,E
D TOBACCO3
I $D(APCLTOB) Q APCLTOB
D TOBACCO0
I $D(APCLTOB) Q APCLTOB
D TOBACCO1 ;check Problem file for tobacco use
I $D(APCLTOB) Q APCLTOB
;D TOBACCO2 ;check POVs for tobacco use
I $D(APCLTOB) Q APCLTOB
Q "4 NOT DOCUMENTED"
TOBACCO0 ;check for tobacco documented in health factors
K APCL S X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
. I $P(APCL(1),U,3)["NON" S APCLTOB="2 NEVER USED" Q
. I $P(APCL(1),U,3)["PREVIOUS" S APCLTOB="3 PAST USE" Q
. S APCLTOB="1 CURRENT USER"
.Q
Q
TOBACCO3 ;lookup in health status
S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
Q:'%
S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
Q:'Y
S Y=$P(^AUTTHF(Y,0),U)
S APCLTOB=Y
I Y["NON" S APCLTOB="2 NEVER USED" Q
I Y["PREVIOUS" S APCLTOB="3 PAST USE" Q
S APCLTOB="1 CURRENT USER"
Q
TOBACCO1 ;check problem file for tobacco use
Q
K APCL S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="3 PAST USE"_" - "_$S($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5):$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30),1:"<no narrative provided>") Q
. S APCLTOB="1 CURRENT USER - "_$S($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5):$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30),1:"<no narrative provided>")
.Q
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
NEW D,%DT
S %DT="P",X=EDATE D ^%DT S D=Y
NEW BDATE S BDATE=$$FMADD^XLFDT(D,-365),BDATE=$$FMTE^XLFDT(BDATE)
K APCL S X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. I $P(APCL(1),U,2)=305.13 S APCLTOB="3 PAST USE"_" - "_$S($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4):$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30),1:"<no narrative provided>") Q
. S APCLTOB="1 CURRENT USER"_" - "_$S($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4):$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30),1:"<no narrative provided>")
.Q
Q
;
FLU(P,EDATE) ;
NEW BDATE S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW CIMG,X,E
S EDATE=$$FMTE^XLFDT(EDATE),BDATE=$$FMTE^XLFDT(BDATE)
S X=P_"^LAST IMM "_$S($$BI:88,1:12)_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"CIMG(")
I $D(CIMG(1)) Q $$FMTE^XLFDT($P(CIMG(1),U))
Q ""
PNEU(P,EDATE) ;
NEW CIMG,X,E
S EDATE=$$FMTE^XLFDT(EDATE)
S X=P_"^LAST IMM "_$S($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"CIMG(")
I $D(CIMG(1)) Q $$FMTE^XLFDT($P(CIMG(1),U))
Q ""
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
PHNV(P,BDATE,EDATE,LOC) ;count all phn visits for this patient
I $G(LOC)="" S LOC=""
NEW A,B,C,X,Y,%,H,Q
K A
S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,"A(")
I '$D(A(1)) Q 0
S (X,Y,C)=0 F S X=$O(A(X)) Q:X'=+X S V=$P(A(X),U,5) D I Y S $P(C,U)=$P(C,U)+1 D HOME
.S (D,Y)=0
.F S D=$O(^AUPNVPRV("AD",V,D)) Q:D'=+D S Q=$P(^AUPNVPRV(D,0),U),%=$$VALI^XBDIQ1($S($P(^AUTTSITE(1,0),U,22):200,1:6),Q,$S($P(^AUTTSITE(1,0),U,22):53.5,1:2)) I % S %=$P($G(^DIC(7,%,9999999)),U) I %=13!(%=32) S Y=1
Q C
;
HOME ;
I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,2)=$P(C,U,2)+1 Q
Q:LOC=""
I LOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,2)=$P(C,U,2)+1
Q
CIMGAGP3 ; CMI/TUCSON/LAB - aberdeen area GPRA ; [ 03/13/00 8:58 PM ]
+1 ;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000
+2 ;
+3 ;
PHN ;
+1 SET X=$$PHNV(DFN,CIMBDATE,CIMEDATE,CIMHOME)
+2 IF $PIECE(X,U)
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),25,1)
+3 IF $PIECE(X,U,2)
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),26,1)
+4 DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),18,$PIECE(X,U))
+5 DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),19,$PIECE(X,U,2))
FLUPNEU ;
+1 SET CIMAGE=$$AGE^AUPNPAT(DFN,CIMBDATE)
+2 IF CIMAGE<65
GOTO SMOKE
+3 DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),20,1)
+4 SET V=$$PNEU(DFN,CIMEDATE)
+5 IF V]""
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),21,1)
+6 IF $DATA(CIMLIST(14))
IF CIMTIME
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",14,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)=V
+7 SET V=$$FLU(DFN,CIMEDATE)
+8 IF V]""
DO S(CIMRPT,$SELECT(CIMTIME:19,1:20),22,1)
+9 IF $DATA(CIMLIST(15))
IF CIMTIME
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",15,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)=V
SMOKE ;
+1 SET X=$$TOBACCO(DFN,CIMEDATE)
+2 IF X]""
IF $EXTRACT(X)'=4
DO S(CIMRPT,$SELECT(CIMTIME:22,1:23),10,1)
+3 IF $EXTRACT(X)=1
IF $DATA(CIMLIST(16))
IF CIMTIME
SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"LIST",16,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),CIMAGE,DFN)=$EXTRACT($PIECE(X," ",2,99),1,22)
+4 IF $EXTRACT(X)=1
DO S(CIMRPT,$SELECT(CIMTIME:22,1:23),1,X)
+5 SET CIMAGEP=$SELECT(CIMAGE=0:2,CIMAGE>0&(CIMAGE<5):3,CIMAGE>4&(CIMAGE<15):4,CIMAGE>14&(CIMAGE<20):5,CIMAGE>19&(CIMAGE<25):6,CIMAGE>24&(CIMAGE<45):7,CIMAGE>44&(CIMAGE<65):8,CIMAGE>64:9,1:BBBBB)
+6 ;set numerator for 1/1 prevalance age piece
IF $EXTRACT(X)=1
DO S(CIMRPT,$SELECT(CIMTIME:22,1:23),CIMAGEP,X)
INJ20 ;any visit with E code
+1 SET CIMNODE=$SELECT(CIMTIME:24,1:25)
+2 ;$o THRU injuries
+3 SET S=$$FMADD^XLFDT(CIMEDATE,1)
+4 SET E=9999999-CIMBDATE
SET B=9999999-S
+5 FOR
SET B=$ORDER(^AUPNVPOV("AA",DFN,B))
IF B'=+B!(B>E)
QUIT
Begin DoDot:1
+6 SET V=0
FOR
SET V=$ORDER(^AUPNVPOV("AA",DFN,B,V))
IF V'=+V
QUIT
Begin DoDot:2
+7 SET Z=$PIECE(^AUPNVPOV(V,0),U,3)
IF '$DATA(^AUPNVSIT(Z,0))
QUIT
+8 SET P=$PIECE(^AUPNVPOV(V,0),U)
SET I=$PIECE(^ICD9(P,0),U)
SET D=$PIECE(^ICD9(P,0),U,3)
+9 IF I<800
QUIT
+10 IF I>996
QUIT
+11 IF $EXTRACT(I,1,3)=816
QUIT
+12 IF $EXTRACT(I,1,3)=826
QUIT
+13 IF $EXTRACT(I,1,3)=834
QUIT
+14 IF I>839.99&(I<846)
QUIT
+15 IF $EXTRACT(I,1,3)=848
QUIT
+16 IF $EXTRACT(I,1,3)>904&($EXTRACT(I,1,3)<925)
QUIT
+17 IF $EXTRACT(I,1,3)>930&($EXTRACT(I,1,3)<940)
QUIT
+18 IF $EXTRACT(I,1,3)>957&($EXTRACT(I,1,3)<961)
QUIT
+19 IF $EXTRACT(I,1,3)>977&($EXTRACT(I,1,3)<981)
QUIT
+20 ;total number of injury diagnoses
DO S(CIMRPT,$SELECT(CIMTIME:22,1:23),11,1)
+21 SET ^XTMP("CIMGAGP",CIMGJ,CIMGH,"INJURIES",$PIECE(^DPT(DFN,0),U),DFN,$PIECE(^AUPNVPOV(V,0),U,3),V)=""
+22 IF '$DATA(^CIMAGP(CIMRPT,CIMNODE,"B",I))
Begin DoDot:3
+23 IF CIMTIME
SET CIMINJC=CIMINJC+1
IF 'CIMTIME
SET CIMINJP=CIMINJP+1
SET ^CIMAGP(CIMRPT,CIMNODE,$SELECT(CIMTIME:CIMINJC,1:CIMINJP),0)=I
SET ^CIMAGP(CIMRPT,CIMNODE,"B",I,$SELECT(CIMTIME:CIMINJC,1:CIMINJP))=""
+24 SET ^CIMAGP(CIMRPT,$SELECT(CIMTIME:24,1:25),0)="^"_$SELECT(CIMTIME:19255.24,1:19255.25)_"^"_$SELECT(CIMTIME:CIMINJC,1:CIMINJP)_"^"_$SELECT(CIMTIME:CIMINJC,1:CIMINJP)
End DoDot:3
+25 SET X=$ORDER(^CIMAGP(CIMRPT,CIMNODE,"B",I,0))
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,2)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,2)+1
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,3)=D
Begin DoDot:3
L SET T=$PIECE(^AUPNVSIT(Z,0),U,3)
SET S=$PIECE(^AUPNVSIT(Z,0),U,7)
+1 IF T="C"
IF S="H"
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)+1
QUIT
+2 IF T="C"
IF S'="H"
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)+1
QUIT
+3 IF "OV"'[T
IF S="H"
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)+1
QUIT
+4 IF "OV"'[T
IF "AORSI"[S
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)+1
QUIT
End DoDot:3
+5 ;alcohol related
+6 SET A=$PIECE(^AUPNVPOV(V,0),U,7)
IF A=2
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,9)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,0),U,9)+1
+7 ;e code tally
+8 SET K=$PIECE(^AUPNVPOV(V,0),U,9)
+9 IF K=""
QUIT
+10 SET EC=$PIECE(^ICD9(K,0),U)
SET M=$PIECE(^ICD9(K,0),U,3)
+11 IF '$DATA(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC))
Begin DoDot:3
+12 ;get next ien
+13 SET (%,%1)=0
FOR
SET %=$ORDER(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,%))
IF %'=+%
QUIT
SET %1=%
+14 SET CIMEN=%1+1
+15 SET ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,CIMEN,0)=EC
SET ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC,CIMEN)=""
+16 SET ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,0)="^"_$SELECT(CIMTIME:19255.2424,1:19255.2525)_"^"_CIMEN_"^"_CIMEN
End DoDot:3
+17 SET Y=$ORDER(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC,0))
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,2)=$PIECE(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,2)+1
SET $PIECE(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,Y,0),U,3)=M
End DoDot:2
End DoDot:1
+18 QUIT
S(R,N,P,V) ;
+1 IF 'R
QUIT
+2 SET $PIECE(^CIMAGP(R,N),U,P)=$PIECE($GET(^CIMAGP(R,N)),U,P)+V
+3 QUIT
+4 ;
TOBACCO(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW APCLTOB,APCL,X,E
+3 DO TOBACCO3
+4 IF $DATA(APCLTOB)
QUIT APCLTOB
+5 DO TOBACCO0
+6 IF $DATA(APCLTOB)
QUIT APCLTOB
+7 ;check Problem file for tobacco use
DO TOBACCO1
+8 IF $DATA(APCLTOB)
QUIT APCLTOB
+9 ;D TOBACCO2 ;check POVs for tobacco use
+10 IF $DATA(APCLTOB)
QUIT APCLTOB
+11 QUIT "4 NOT DOCUMENTED"
TOBACCO0 ;check for tobacco documented in health factors
+1 ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
KILL APCL
SET X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+2 IF $PIECE(APCL(1),U,3)["NON"
SET APCLTOB="2 NEVER USED"
QUIT
+3 IF $PIECE(APCL(1),U,3)["PREVIOUS"
SET APCLTOB="3 PAST USE"
QUIT
+4 SET APCLTOB="1 CURRENT USER"
+5 QUIT
End DoDot:1
+6 QUIT
TOBACCO3 ;lookup in health status
+1 SET %=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
+2 IF '%
QUIT
+3 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+4 IF 'Y
QUIT
+5 SET Y=$PIECE(^AUTTHF(Y,0),U)
+6 SET APCLTOB=Y
+7 IF Y["NON"
SET APCLTOB="2 NEVER USED"
QUIT
+8 IF Y["PREVIOUS"
SET APCLTOB="3 PAST USE"
QUIT
+9 SET APCLTOB="1 CURRENT USER"
+10 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 QUIT
+2 KILL APCL
SET X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+3 IF $PIECE(^ICD9($PIECE(APCL(1),U,2),0),U,1)=305.13
SET APCLTOB="3 PAST USE"_" - "_$SELECT($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5):$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30),1:"<no narrative provided>")
QUIT
+4 SET APCLTOB="1 CURRENT USER - "_$SELECT($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5):$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30),1:"<no narrative provided>")
+5 QUIT
End DoDot:1
+6 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 NEW D,%DT
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET D=Y
+3 NEW BDATE
SET BDATE=$$FMADD^XLFDT(D,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
+4 KILL APCL
SET X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+5 IF $PIECE(APCL(1),U,2)=305.13
SET APCLTOB="3 PAST USE"_" - "_$SELECT($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4):$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30),1:"<no narrative provided>")
QUIT
+6 SET APCLTOB="1 CURRENT USER"_" - "_$SELECT($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4):$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30),1:"<no narrative provided>")
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
FLU(P,EDATE) ;
+1 NEW BDATE
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+2 NEW CIMG,X,E
+3 SET EDATE=$$FMTE^XLFDT(EDATE)
SET BDATE=$$FMTE^XLFDT(BDATE)
+4 SET X=P_"^LAST IMM "_$SELECT($$BI:88,1:12)_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"CIMG(")
+5 IF $DATA(CIMG(1))
QUIT $$FMTE^XLFDT($PIECE(CIMG(1),U))
+6 QUIT ""
PNEU(P,EDATE) ;
+1 NEW CIMG,X,E
+2 SET EDATE=$$FMTE^XLFDT(EDATE)
+3 SET X=P_"^LAST IMM "_$SELECT($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"CIMG(")
+4 IF $DATA(CIMG(1))
QUIT $$FMTE^XLFDT($PIECE(CIMG(1),U))
+5 QUIT ""
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
PHNV(P,BDATE,EDATE,LOC) ;count all phn visits for this patient
+1 IF $GET(LOC)=""
SET LOC=""
+2 NEW A,B,C,X,Y,%,H,Q
+3 KILL A
+4 SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,"A(")
+5 IF '$DATA(A(1))
QUIT 0
+6 SET (X,Y,C)=0
FOR
SET X=$ORDER(A(X))
IF X'=+X
QUIT
SET V=$PIECE(A(X),U,5)
Begin DoDot:1
+7 SET (D,Y)=0
+8 FOR
SET D=$ORDER(^AUPNVPRV("AD",V,D))
IF D'=+D
QUIT
SET Q=$PIECE(^AUPNVPRV(D,0),U)
SET %=$$VALI^XBDIQ1($SELECT($PIECE(^AUTTSITE(1,0),U,22):200,1:6),Q,$SELECT($PIECE(^AUTTSITE(1,0),U,22):53.5,1:2))
IF %
SET %=$PIECE($GET(^DIC(7,%,9999999)),U)
IF %=13!(%=32)
SET Y=1
End DoDot:1
IF Y
SET $PIECE(C,U)=$PIECE(C,U)+1
DO HOME
+9 QUIT C
+10 ;
HOME ;
+1 IF $$CLINIC^APCLV(V,"C")=11
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
QUIT
+2 IF LOC=""
QUIT
+3 IF LOC=$PIECE(^AUPNVSIT(V,0),U,6)
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
+4 QUIT
