- 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