Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: CIMGAGP3

CIMGAGP3.m

Go to the documentation of this file.
  1. CIMGAGP3 ; CMI/TUCSON/LAB - aberdeen area GPRA ; [ 03/13/00 8:58 PM ]
  1. ;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000
  1. ;
  1. ;
  1. PHN ;
  1. S X=$$PHNV(DFN,CIMBDATE,CIMEDATE,CIMHOME)
  1. I $P(X,U) D S(CIMRPT,$S(CIMTIME:19,1:20),25,1)
  1. I $P(X,U,2) D S(CIMRPT,$S(CIMTIME:19,1:20),26,1)
  1. D S(CIMRPT,$S(CIMTIME:19,1:20),18,$P(X,U))
  1. D S(CIMRPT,$S(CIMTIME:19,1:20),19,$P(X,U,2))
  1. FLUPNEU ;
  1. S CIMAGE=$$AGE^AUPNPAT(DFN,CIMBDATE)
  1. G:CIMAGE<65 SMOKE
  1. D S(CIMRPT,$S(CIMTIME:19,1:20),20,1)
  1. S V=$$PNEU(DFN,CIMEDATE)
  1. I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),21,1)
  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
  1. S V=$$FLU(DFN,CIMEDATE)
  1. I V]"" D S(CIMRPT,$S(CIMTIME:19,1:20),22,1)
  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
  1. SMOKE ;
  1. S X=$$TOBACCO(DFN,CIMEDATE)
  1. I X]"",$E(X)'=4 D S(CIMRPT,$S(CIMTIME:22,1:23),10,1)
  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)
  1. I $E(X)=1 D S(CIMRPT,$S(CIMTIME:22,1:23),1,X)
  1. 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)
  1. I $E(X)=1 D S(CIMRPT,$S(CIMTIME:22,1:23),CIMAGEP,X) ;set numerator for 1/1 prevalance age piece
  1. INJ20 ;any visit with E code
  1. S CIMNODE=$S(CIMTIME:24,1:25)
  1. ;$o THRU injuries
  1. S S=$$FMADD^XLFDT(CIMEDATE,1)
  1. S E=9999999-CIMBDATE,B=9999999-S
  1. F S B=$O(^AUPNVPOV("AA",DFN,B)) Q:B'=+B!(B>E) D
  1. .S V=0 F S V=$O(^AUPNVPOV("AA",DFN,B,V)) Q:V'=+V D
  1. ..S Z=$P(^AUPNVPOV(V,0),U,3) Q:'$D(^AUPNVSIT(Z,0))
  1. ..S P=$P(^AUPNVPOV(V,0),U),I=$P(^ICD9(P,0),U),D=$P(^ICD9(P,0),U,3)
  1. ..Q:I<800
  1. ..Q:I>996
  1. ..Q:$E(I,1,3)=816
  1. ..Q:$E(I,1,3)=826
  1. ..Q:$E(I,1,3)=834
  1. ..Q:I>839.99&(I<846)
  1. ..Q:$E(I,1,3)=848
  1. ..Q:$E(I,1,3)>904&($E(I,1,3)<925)
  1. ..Q:$E(I,1,3)>930&($E(I,1,3)<940)
  1. ..Q:$E(I,1,3)>957&($E(I,1,3)<961)
  1. ..Q:$E(I,1,3)>977&($E(I,1,3)<981)
  1. ..D S(CIMRPT,$S(CIMTIME:22,1:23),11,1) ;total number of injury diagnoses
  1. ..S ^XTMP("CIMGAGP",CIMGJ,CIMGH,"INJURIES",$P(^DPT(DFN,0),U),DFN,$P(^AUPNVPOV(V,0),U,3),V)=""
  1. ..I '$D(^CIMAGP(CIMRPT,CIMNODE,"B",I)) D
  1. ...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))=""
  1. ...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)
  1. ..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
  1. L ...S T=$P(^AUPNVSIT(Z,0),U,3),S=$P(^AUPNVSIT(Z,0),U,7)
  1. ...I T="C",S="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,7)+1 Q
  1. ...I T="C",S'="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,8)+1 Q
  1. ...I "OV"'[T,S="H" S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,5)+1 Q
  1. ...I "OV"'[T,"AORSI"[S S $P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)=$P(^CIMAGP(CIMRPT,CIMNODE,X,0),U,6)+1 Q
  1. ..;alcohol related
  1. ..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
  1. ..;e code tally
  1. ..S K=$P(^AUPNVPOV(V,0),U,9)
  1. ..Q:K=""
  1. ..S EC=$P(^ICD9(K,0),U),M=$P(^ICD9(K,0),U,3)
  1. ..I '$D(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC)) D
  1. ...;get next ien
  1. ...S (%,%1)=0 F S %=$O(^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,%)) Q:%'=+% S %1=%
  1. ...S CIMEN=%1+1
  1. ...S ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,CIMEN,0)=EC,^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,"B",EC,CIMEN)=""
  1. ...S ^CIMAGP(CIMRPT,CIMNODE,X,CIMNODE,0)="^"_$S(CIMTIME:19255.2424,1:19255.2525)_"^"_CIMEN_"^"_CIMEN
  1. ..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
  1. Q
  1. S(R,N,P,V) ;
  1. I 'R Q
  1. S $P(^CIMAGP(R,N),U,P)=$P($G(^CIMAGP(R,N)),U,P)+V
  1. Q
  1. ;
  1. TOBACCO(P,EDATE) ;EP
  1. I '$G(P) Q ""
  1. NEW APCLTOB,APCL,X,E
  1. D TOBACCO3
  1. I $D(APCLTOB) Q APCLTOB
  1. D TOBACCO0
  1. I $D(APCLTOB) Q APCLTOB
  1. D TOBACCO1 ;check Problem file for tobacco use
  1. I $D(APCLTOB) Q APCLTOB
  1. ;D TOBACCO2 ;check POVs for tobacco use
  1. I $D(APCLTOB) Q APCLTOB
  1. Q "4 NOT DOCUMENTED"
  1. TOBACCO0 ;check for tobacco documented in health factors
  1. 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)
  1. . I $P(APCL(1),U,3)["NON" S APCLTOB="2 NEVER USED" Q
  1. . I $P(APCL(1),U,3)["PREVIOUS" S APCLTOB="3 PAST USE" Q
  1. . S APCLTOB="1 CURRENT USER"
  1. .Q
  1. Q
  1. TOBACCO3 ;lookup in health status
  1. S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
  1. Q:'%
  1. 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
  1. Q:'Y
  1. S Y=$P(^AUTTHF(Y,0),U)
  1. S APCLTOB=Y
  1. I Y["NON" S APCLTOB="2 NEVER USED" Q
  1. I Y["PREVIOUS" S APCLTOB="3 PAST USE" Q
  1. S APCLTOB="1 CURRENT USER"
  1. Q
  1. TOBACCO1 ;check problem file for tobacco use
  1. Q
  1. K APCL S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
  1. . 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
  1. . 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>")
  1. .Q
  1. Q
  1. TOBACCO2 ;check pov file for TOBACCO USE DOC
  1. NEW D,%DT
  1. S %DT="P",X=EDATE D ^%DT S D=Y
  1. NEW BDATE S BDATE=$$FMADD^XLFDT(D,-365),BDATE=$$FMTE^XLFDT(BDATE)
  1. 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
  1. . 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
  1. . 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>")
  1. .Q
  1. Q
  1. ;
  1. FLU(P,EDATE) ;
  1. NEW BDATE S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. NEW CIMG,X,E
  1. S EDATE=$$FMTE^XLFDT(EDATE),BDATE=$$FMTE^XLFDT(BDATE)
  1. S X=P_"^LAST IMM "_$S($$BI:88,1:12)_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"CIMG(")
  1. I $D(CIMG(1)) Q $$FMTE^XLFDT($P(CIMG(1),U))
  1. Q ""
  1. PNEU(P,EDATE) ;
  1. NEW CIMG,X,E
  1. S EDATE=$$FMTE^XLFDT(EDATE)
  1. S X=P_"^LAST IMM "_$S($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"CIMG(")
  1. I $D(CIMG(1)) Q $$FMTE^XLFDT($P(CIMG(1),U))
  1. Q ""
  1. BI() ;
  1. Q $S($O(^AUTTIMM(0))>100:1,1:0)
  1. PHNV(P,BDATE,EDATE,LOC) ;count all phn visits for this patient
  1. I $G(LOC)="" S LOC=""
  1. NEW A,B,C,X,Y,%,H,Q
  1. K A
  1. S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,"A(")
  1. I '$D(A(1)) Q 0
  1. 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
  1. .S (D,Y)=0
  1. .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
  1. Q C
  1. ;
  1. HOME ;
  1. I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,2)=$P(C,U,2)+1 Q
  1. Q:LOC=""
  1. I LOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,2)=$P(C,U,2)+1
  1. Q