PXRRPCE3 ;HIN/MjK - Clinic Specific Workload Reports ;10 Sep 2013 10:48 AM
;;1.0;PCE PATIENT CARE ENCOUNTER;**121,146,199**;Aug 12, 1996;Build 51
EN ;_._._._._._._.Visit Totals/ Patient Ages/ Unsched Totals_._._._._._.
N ICD10250,ICD10401,ICDCSYS,ICDDATA,PXDXDATE
; Z = Visit Dt/Time
D INITVAR^PXRRPCE5 ;Initialize counter variables
S (X,Y)=0 F S X=$O(PXRRCLIN(X)) Q:'X S Y=Y+1,PXRCLNUM=Y
S PXRRY=PXRRYR F S PXRRY=$O(^AUPNVSIT("B",PXRRY)) Q:'PXRRY!((PXRRY>PXRREDT)) D
. S PXRRVIFN=0 F S PXRRVIFN=$O(^AUPNVSIT("B",PXRRY,PXRRVIFN)) Q:'PXRRVIFN I $P($G(^AUPNVSIT(PXRRVIFN,0)),U,22)=PXRRCLIN D
.. S X=$P($G(^AUPNVSIT(PXRRVIFN,0)),U,7) Q:X'="A"&(X'="I")&(X'="S")
.. S Z=$P(^AUPNVSIT(PXRRVIFN,0),U),DFN=$P(^AUPNVSIT(PXRRVIFN,0),U,5)
.. S PXDXDATE=$$CSDATE^PXDXUTL(PXRRVIFN) ; set diagnosis date separate from Visit date for "E" records
.. ;_._._._._._._._.Demographics - Sessions, Ages_._._._._._._._.
.. S PXRRTVS=PXRRTVS+1 I Z>PXRRBDT S PXRRSESS=$S($D(Z($P(Z,"."))):PXRRSESS,1:PXRRSESS+1),Z($P(Z,"."))=""
.. D AGE
.. ;_._._._._._._._._._All Clinic Patients_._._._._._._._._._
.. S PXRRAPT=$P(Z,".")
.. F S PXRRAPT=$O(^DPT(DFN,"S",PXRRAPT)) Q:'PXRRAPT!(PXRRAPT>($$FMADD^XLFDT(PXRRAPT,1))) I $P(^DPT(DFN,"S",PXRRAPT,0),U)=PXRRCLIN S:$P(^DPT(DFN,"S",PXRRAPT,0),U,7)=4 PXRRSXUN=PXRRSXUN+1
.. S ^TMP($J,PXRRCLIN,"PATIENT APPTS",Z,DFN)=""
.. S ^TMP($J,PXRRCLIN,"CLINIC PATIENTS",DFN)=""
.. ;_._._._._._._._._._._._._Diagnoses_._._._._._._._._._._._._.
.. ;B = V POV IEN ; C = ICD Code
.. S B="" F S B=$O(^AUPNVPOV("AD",PXRRVIFN,B)) Q:'B D
... S ICDDATA=$$ICDDATA^ICDXCODE("DIAG",$P(^AUPNVPOV(B,0),U),PXDXDATE,"I")
... S C=$P(ICDDATA,U,2),ICDCSYS($S($P(ICDDATA,U,20)="30":"10D",1:"ICD"))=""
... S C=$S('+C:C,1:+C)
... S:(C'?1"272.".E)&(C'?1"305.".E)&(C'?1"E78.".E)&(C'?1"F17.2".E)&(C'="Z72.0") C=$P(C,".")
... S ^TMP($J,PXRRCLIN,"ICD",Z,C,DFN)="",^TMP($J,PXRRCLIN,"ICD PAT",C,DFN,Z)=""
MEDAGE ;_._._._._._._._._._._._._._Median Age_._._._._._._._._._._._._._._.
S X=0 F S X=$O(^TMP($J,PXRRCLIN,"PATIENT AGE",X)) Q:'X S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"PATIENT AGE",X,DFN)) Q:'DFN D
. S Y=$G(^TMP($J,PXRRCLIN,"PATIENT AGE",X,DFN))
. I (Y>PXRRBDT),(Y<PXRREDT) S PXRRAGE=PXRRAGE+1,Y(PXRRAGE)=X
S PXRRAGE=PXRRAGE\2,PXRRAG=$G(Y(PXRRAGE)) K Y
;_._._._._._._._._._._._._._Diagnosis Totals_._._._._._._._._._._._._.
;C = ICD ;E = date
Q:'$D(^TMP($J,PXRRCLIN,"CLINIC PATIENTS"))!'(PXRRSESS)
F C=272.2,272.4,250,401,414,"I25","E08","E09","E10","E11","E12","E13","I10","I11","I12","I13","I14","I15","E78.0","E78.1","E78.2","E78.3","E78.4","E78.5","F17.2",305.1 S PXRR(C)=0
;S E=0 F S E=$O(^TMP($J,PXRRCLIN,"ICD",E)) Q:'E D
;. I $D(^TMP($J,PXRRCLIN,"ICD",E,C)) S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD",E,C,DFN)) Q:'DFN D
;.. S PXRR(C)=$S('$D(C(DFN)):PXRR(C)+1,1:PXRR(C)),C(DFN)=""
K C S E=PXRRBDT F S E=$O(^TMP($J,PXRRCLIN,"ICD",E)) Q:'E!(E>PXRREDT) D
. S C=0 F S C=$O(^TMP($J,PXRRCLIN,"ICD",E,C)) Q:C="" D
.. S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD",E,C,DFN)) Q:'DFN D
... I '$D(PXRR(C)) S PXRR(C)=0
... S PXRR(C)=$S('$D(C(C,DFN)):PXRR(C)+1,1:0),C(C,DFN)=""
K C S PXRR(272)=PXRR(272.4)+$G(PXRR(272.2))
S PXRR(305)=0 F C=305.1:.01:305.13 S PXRR(305)=PXRR(305)+$G(PXRR(C))
S PXRR("F17.2")=0 S C="F17.2" F S C=$O(PXRR(C)) Q:C="" Q:C'?1"F17.2".E D
.I "^200^203^208^209^210^213^218^219^220^223^228^229^290^293^298^299^"[("^"_$P(C,".",2)_"^") D
..S PXRR("F17.2")=PXRR("F17.2")+$G(PXRR(C))
S PXRR("F17.2")=PXRR("F17.2")+$G(PXRR("Z72.0"))
S PXRR("E78")=PXRR("E78.0")+PXRR("E78.1")+PXRR("E78.2")+PXRR("E78.3")+PXRR("E78.4")+PXRR("E78.5")
S ICD10250=$G(PXRR("E08"))+$G(PXRR("E09"))+$G(PXRR("E10"))+$G(PXRR("E11"))+$G(PXRR("E12"))+$G(PXRR("E13"))
S ICD10401=$G(PXRR("I10"))+$G(PXRR("I11"))+$G(PXRR("I12"))+$G(PXRR("I13"))+$G(PXRR("I14"))+$G(PXRR("I15"))
S PXRRDM=$S($D(ICDCSYS("ICD")):$G(PXRR(250)),1:0)+$S($D(ICDCSYS("10D")):ICD10250,1:0)
S PXRRHTN=$S($D(ICDCSYS("ICD")):$G(PXRR(401)),1:0)+$S($D(ICDCSYS("10D")):ICD10401,1:0)
S PXRRCAD=$S($D(ICDCSYS("ICD")):$G(PXRR(414)),1:0)+$S($D(ICDCSYS("10D")):PXRR("I25"),1:0)
S PXRRHLIP=$S($D(ICDCSYS("ICD")):PXRR(272),1:0)+$S($D(ICDCSYS("10D")):PXRR("E78"),1:0)
S PXRRSMYR=$S($D(ICDCSYS("ICD")):PXRR(305),1:0)+$S($D(ICDCSYS("10D")):PXRR("F17.2"),1:0)
;_._._._._._._._._.Diabetes and Hypertensive Patients_._._._._._._._.
HTDM S PXRRHTDM=0,E=PXRRBDT G:'$D(ICDCSYS("ICD")) HTDM2 F S E=$O(^TMP($J,PXRRCLIN,"ICD",E)) Q:'E!(E>PXRREDT) D
. S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD",E,250,DFN)) Q:'DFN I $D(^TMP($J,PXRRCLIN,"ICD PAT",401,DFN)) D
.. S X=PXRRBDT F S X=$O(^TMP($J,PXRRCLIN,"ICD PAT",401,DFN,X)) Q:'X I X<PXRREDT S PXRRHTDM=PXRRHTDM+1
HTDM2 G:'$D(ICDCSYS("10D")) SMOCAD F S E=$O(^TMP($J,PXRRCLIN,"ICD",E)) Q:'E!(E>PXRREDT) D
. S C="E07" F S C=$O(^TMP($J,PXRRCLIN,"ICD",E,C)) Q:"^E08^E09^E10^E11^E12^E13^"'[(U_$E(C,1,3)_U) D
.. S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD",E,C,DFN)) Q:'DFN D
... F C2="I10","I11","I12","I13","I14","I15" I $D(^TMP($J,PXRRCLIN,"ICD PAT",C2,DFN)) D
.... S X=PXRRBDT F S X=$O(^TMP($J,PXRRCLIN,"ICD PAT",C2,DFN,X)) Q:'X I X<PXRREDT S PXRRHTDM=PXRRHTDM+1
; _._._._._._._._._._._Smokers with CAD DX_._._._._._._._._._._._._.
SMOCAD S PXRRCDSM=0 G:'$D(ICDCSYS("ICD")) SMOCAD2
S C=304 F S C=$O(^TMP($J,PXRRCLIN,"ICD PAT",C)) Q:'C!(C>305.13) D
. S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD PAT",C,DFN)) Q:'DFN D
.. S E=PXRRSXMO F S E=$O(^TMP($J,PXRRCLIN,"ICD PAT",C,DFN,E)) Q:'E D
... I $D(^TMP($J,PXRRCLIN,"ICD PAT",414,DFN)) S PXRRCDSM=PXRRCDSM+1
SMOCAD2 G:'$D(ICDCSYS("10D")) HBA1
S C="F17.2" F S C=$O(^TMP($J,PXRRCLIN,"ICD PAT",C)) Q:(C'?1"F17.2".E) D
. I "^200^203^208^209^210^213^218^219^220^223^228^229^290^293^298^299^"'[("^"_$P(C,".",2)_"^") Q
. S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD PAT",C,DFN)) Q:'DFN D
.. S E=PXRRSXMO F S E=$O(^TMP($J,PXRRCLIN,"ICD PAT",C,DFN,E)) Q:'E D
... I $D(^TMP($J,PXRRCLIN,"ICD PAT","I25",DFN)) S PXRRCDSM=PXRRCDSM+1
S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD PAT","Z72.0",DFN)) Q:'DFN D
. S E=PXRRSXMO F S E=$O(^TMP($J,PXRRCLIN,"ICD PAT","Z72.0",DFN,E)) Q:'E D
.. I $D(^TMP($J,PXRRCLIN,"ICD PAT","I25",DFN)) S PXRRCDSM=PXRRCDSM+1
HBA1 ; _._._._._._._._._._.HTN AND/OR HBA1C w/ DM DX_._._._._._._._._._._._.
; **Site Specific Entries for Selected Labs**
S PX=$O(^PX(815,0)),(DFN,PXRRHBA1)=0,PXRRLED=(9999999.9999999-PXRRSXMO)
K C,C2 S:$D(ICDCSYS("ICD")) C(250)="" I $D(ICDCSYS("10D")) F C2="E08","E09","E10","E11","E12","E13" S C(C2)=""
S C2="" F S C2=$O(C(C2)) Q:C2="" D
.F S DFN=$O(^TMP($J,PXRRCLIN,"ICD PAT",C2,DFN)) Q:'DFN D
.. S PXRLRDFN=$P($G(^DPT(DFN,"LR")),U) Q:'PXRLRDFN S L=0 F S L=$O(^PX(815,PX,"RR5",L)) Q:'L D
... S X=$P(^PX(815,PX,"RR5",L,0),U),X=$P($P(^LAB(60,X,0),U,5),";",2),E=9999999.9999999-DT F S E=$O(^LR(PXRLRDFN,"CH",E)) Q:'E!(E>PXRRLED) D
.... I +$P($G(^LR(PXRLRDFN,"CH",E,X)),U) D
..... S PXRRHBA1=PXRRHBA1+$P($G(^LR(PXRLRDFN,"CH",E,X)),U),^TMP($J,PXRRCLIN,"HBA1C",DFN,E)=$P($G(^LR(PXRLRDFN,"CH",E,X)),U)
S (PXRRHBG7,PXRRHBPT,DFN)=0
F S DFN=$O(^TMP($J,PXRRCLIN,"HBA1C",DFN)) Q:'DFN S X=0 F S X=$O(^TMP($J,PXRRCLIN,"HBA1C",DFN,X)) Q:'X S PXRRHBPT=PXRRHBPT+1 D
. I $G(^TMP($J,PXRRCLIN,"HBA1C",DFN,X))>6.99,'$D(X(DFN)) S PXRRHBG7=PXRRHBG7+1
. S X(DFN)=""
K X I $G(PXRRHBA1)>0 S PXRRHBA1=PXRRHBA1/PXRRHBPT
S:'PXRRHBPT PXRRHBA1="N/A",PXRRHBG7=0
SXUTTOT ;_._._._._._._._._.Quality Care & Util 7 other Totals_._._._._._._._.
D ^PXRRPCE4
I '$D(^TMP($J,PXRRCLIN,"CLINIC PATIENTS")) S ^TMP($J,PXRRCLIN,"PATIENT","NONE",PXRRCLIN)=""
Q
AGE ;_._._._._._._._._._.Calculate a patient's age_._._._._._._._._._.
I $D(^TMP($J,PXRRCLIN,"CLINIC PATIENTS",DFN)) S X=0 Q
D DEM^VADPT I VADM(4) S ^TMP($J,PXRRCLIN,"PATIENT AGE",VADM(4),DFN)=Z D KVAR^VADPT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRPCE3 7822 printed Apr 09, 2024@21:31:10 Page 2
PXRRPCE3 ;HIN/MjK - Clinic Specific Workload Reports ;10 Sep 2013 10:48 AM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,146,199**;Aug 12, 1996;Build 51
EN ;_._._._._._._.Visit Totals/ Patient Ages/ Unsched Totals_._._._._._.
+1 NEW ICD10250,ICD10401,ICDCSYS,ICDDATA,PXDXDATE
+2 ; Z = Visit Dt/Time
+3 ;Initialize counter variables
DO INITVAR^PXRRPCE5
+4 SET (X,Y)=0
FOR
SET X=$ORDER(PXRRCLIN(X))
if 'X
QUIT
SET Y=Y+1
SET PXRCLNUM=Y
+5 SET PXRRY=PXRRYR
FOR
SET PXRRY=$ORDER(^AUPNVSIT("B",PXRRY))
if 'PXRRY!((PXRRY>PXRREDT))
QUIT
Begin DoDot:1
+6 SET PXRRVIFN=0
FOR
SET PXRRVIFN=$ORDER(^AUPNVSIT("B",PXRRY,PXRRVIFN))
if 'PXRRVIFN
QUIT
IF $PIECE($GET(^AUPNVSIT(PXRRVIFN,0)),U,22)=PXRRCLIN
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVSIT(PXRRVIFN,0)),U,7)
if X'="A"&(X'="I")&(X'="S")
QUIT
+8 SET Z=$PIECE(^AUPNVSIT(PXRRVIFN,0),U)
SET DFN=$PIECE(^AUPNVSIT(PXRRVIFN,0),U,5)
+9 ; set diagnosis date separate from Visit date for "E" records
SET PXDXDATE=$$CSDATE^PXDXUTL(PXRRVIFN)
+10 ;_._._._._._._._.Demographics - Sessions, Ages_._._._._._._._.
+11 SET PXRRTVS=PXRRTVS+1
IF Z>PXRRBDT
SET PXRRSESS=$SELECT($DATA(Z($PIECE(Z,"."))):PXRRSESS,1:PXRRSESS+1)
SET Z($PIECE(Z,"."))=""
+12 DO AGE
+13 ;_._._._._._._._._._All Clinic Patients_._._._._._._._._._
+14 SET PXRRAPT=$PIECE(Z,".")
+15 FOR
SET PXRRAPT=$ORDER(^DPT(DFN,"S",PXRRAPT))
if 'PXRRAPT!(PXRRAPT>($$FMADD^XLFDT(PXRRAPT,1)))
QUIT
IF $PIECE(^DPT(DFN,"S",PXRRAPT,0),U)=PXRRCLIN
if $PIECE(^DPT(DFN,"S",PXRRAPT,0),U,7)=4
SET PXRRSXUN=PXRRSXUN+1
+16 SET ^TMP($JOB,PXRRCLIN,"PATIENT APPTS",Z,DFN)=""
+17 SET ^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",DFN)=""
+18 ;_._._._._._._._._._._._._Diagnoses_._._._._._._._._._._._._.
+19 ;B = V POV IEN ; C = ICD Code
+20 SET B=""
FOR
SET B=$ORDER(^AUPNVPOV("AD",PXRRVIFN,B))
if 'B
QUIT
Begin DoDot:3
+21 SET ICDDATA=$$ICDDATA^ICDXCODE("DIAG",$PIECE(^AUPNVPOV(B,0),U),PXDXDATE,"I")
+22 SET C=$PIECE(ICDDATA,U,2)
SET ICDCSYS($SELECT($PIECE(ICDDATA,U,20)="30":"10D",1:"ICD"))=""
+23 SET C=$SELECT('+C:C,1:+C)
+24 if (C'?1"272.".E)&(C'?1"305.".E)&(C'?1"E78.".E)&(C'?1"F17.2".E)&(C'="Z72.0")
SET C=$PIECE(C,".")
+25 SET ^TMP($JOB,PXRRCLIN,"ICD",Z,C,DFN)=""
SET ^TMP($JOB,PXRRCLIN,"ICD PAT",C,DFN,Z)=""
End DoDot:3
End DoDot:2
End DoDot:1
MEDAGE ;_._._._._._._._._._._._._._Median Age_._._._._._._._._._._._._._._.
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT AGE",X))
if 'X
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT AGE",X,DFN))
if 'DFN
QUIT
Begin DoDot:1
+2 SET Y=$GET(^TMP($JOB,PXRRCLIN,"PATIENT AGE",X,DFN))
+3 IF (Y>PXRRBDT)
IF (Y<PXRREDT)
SET PXRRAGE=PXRRAGE+1
SET Y(PXRRAGE)=X
End DoDot:1
+4 SET PXRRAGE=PXRRAGE\2
SET PXRRAG=$GET(Y(PXRRAGE))
KILL Y
+5 ;_._._._._._._._._._._._._._Diagnosis Totals_._._._._._._._._._._._._.
+6 ;C = ICD ;E = date
+7 if '$DATA(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS"))!'(PXRRSESS)
QUIT
+8 FOR C=272.2,272.4,250,401,414,"I25","E08","E09","E10","E11","E12","E13","I10","I11","I12","I13","I14","I15","E78.0","E78.1","E78.2","E78.3","E78.4","E78.5","F17.2",305.1
SET PXRR(C)=0
+9 ;S E=0 F S E=$O(^TMP($J,PXRRCLIN,"ICD",E)) Q:'E D
+10 ;. I $D(^TMP($J,PXRRCLIN,"ICD",E,C)) S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"ICD",E,C,DFN)) Q:'DFN D
+11 ;.. S PXRR(C)=$S('$D(C(DFN)):PXRR(C)+1,1:PXRR(C)),C(DFN)=""
+12 KILL C
SET E=PXRRBDT
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E))
if 'E!(E>PXRREDT)
QUIT
Begin DoDot:1
+13 SET C=0
FOR
SET C=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E,C))
if C=""
QUIT
Begin DoDot:2
+14 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E,C,DFN))
if 'DFN
QUIT
Begin DoDot:3
+15 IF '$DATA(PXRR(C))
SET PXRR(C)=0
+16 SET PXRR(C)=$SELECT('$DATA(C(C,DFN)):PXRR(C)+1,1:0)
SET C(C,DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 KILL C
SET PXRR(272)=PXRR(272.4)+$GET(PXRR(272.2))
+18 SET PXRR(305)=0
FOR C=305.1:.01:305.13
SET PXRR(305)=PXRR(305)+$GET(PXRR(C))
+19 SET PXRR("F17.2")=0
SET C="F17.2"
FOR
SET C=$ORDER(PXRR(C))
if C=""
QUIT
if C'?1"F17.2".E
QUIT
Begin DoDot:1
+20 IF "^200^203^208^209^210^213^218^219^220^223^228^229^290^293^298^299^"[("^"_$PIECE(C,".",2)_"^")
Begin DoDot:2
+21 SET PXRR("F17.2")=PXRR("F17.2")+$GET(PXRR(C))
End DoDot:2
End DoDot:1
+22 SET PXRR("F17.2")=PXRR("F17.2")+$GET(PXRR("Z72.0"))
+23 SET PXRR("E78")=PXRR("E78.0")+PXRR("E78.1")+PXRR("E78.2")+PXRR("E78.3")+PXRR("E78.4")+PXRR("E78.5")
+24 SET ICD10250=$GET(PXRR("E08"))+$GET(PXRR("E09"))+$GET(PXRR("E10"))+$GET(PXRR("E11"))+$GET(PXRR("E12"))+$GET(PXRR("E13"))
+25 SET ICD10401=$GET(PXRR("I10"))+$GET(PXRR("I11"))+$GET(PXRR("I12"))+$GET(PXRR("I13"))+$GET(PXRR("I14"))+$GET(PXRR("I15"))
+26 SET PXRRDM=$SELECT($DATA(ICDCSYS("ICD")):$GET(PXRR(250)),1:0)+$SELECT($DATA(ICDCSYS("10D")):ICD10250,1:0)
+27 SET PXRRHTN=$SELECT($DATA(ICDCSYS("ICD")):$GET(PXRR(401)),1:0)+$SELECT($DATA(ICDCSYS("10D")):ICD10401,1:0)
+28 SET PXRRCAD=$SELECT($DATA(ICDCSYS("ICD")):$GET(PXRR(414)),1:0)+$SELECT($DATA(ICDCSYS("10D")):PXRR("I25"),1:0)
+29 SET PXRRHLIP=$SELECT($DATA(ICDCSYS("ICD")):PXRR(272),1:0)+$SELECT($DATA(ICDCSYS("10D")):PXRR("E78"),1:0)
+30 SET PXRRSMYR=$SELECT($DATA(ICDCSYS("ICD")):PXRR(305),1:0)+$SELECT($DATA(ICDCSYS("10D")):PXRR("F17.2"),1:0)
+31 ;_._._._._._._._._.Diabetes and Hypertensive Patients_._._._._._._._.
HTDM SET PXRRHTDM=0
SET E=PXRRBDT
if '$DATA(ICDCSYS("ICD"))
GOTO HTDM2
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E))
if 'E!(E>PXRREDT)
QUIT
Begin DoDot:1
+1 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E,250,DFN))
if 'DFN
QUIT
IF $DATA(^TMP($JOB,PXRRCLIN,"ICD PAT",401,DFN))
Begin DoDot:2
+2 SET X=PXRRBDT
FOR
SET X=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",401,DFN,X))
if 'X
QUIT
IF X<PXRREDT
SET PXRRHTDM=PXRRHTDM+1
End DoDot:2
End DoDot:1
HTDM2 if '$DATA(ICDCSYS("10D"))
GOTO SMOCAD
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E))
if 'E!(E>PXRREDT)
QUIT
Begin DoDot:1
+1 SET C="E07"
FOR
SET C=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E,C))
if "^E08^E09^E10^E11^E12^E13^"'[(U_$EXTRACT(C,1,3)_U)
QUIT
Begin DoDot:2
+2 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD",E,C,DFN))
if 'DFN
QUIT
Begin DoDot:3
+3 FOR C2="I10","I11","I12","I13","I14","I15"
IF $DATA(^TMP($JOB,PXRRCLIN,"ICD PAT",C2,DFN))
Begin DoDot:4
+4 SET X=PXRRBDT
FOR
SET X=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C2,DFN,X))
if 'X
QUIT
IF X<PXRREDT
SET PXRRHTDM=PXRRHTDM+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+5 ; _._._._._._._._._._._Smokers with CAD DX_._._._._._._._._._._._._.
SMOCAD SET PXRRCDSM=0
if '$DATA(ICDCSYS("ICD"))
GOTO SMOCAD2
+1 SET C=304
FOR
SET C=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C))
if 'C!(C>305.13)
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C,DFN))
if 'DFN
QUIT
Begin DoDot:2
+3 SET E=PXRRSXMO
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C,DFN,E))
if 'E
QUIT
Begin DoDot:3
+4 IF $DATA(^TMP($JOB,PXRRCLIN,"ICD PAT",414,DFN))
SET PXRRCDSM=PXRRCDSM+1
End DoDot:3
End DoDot:2
End DoDot:1
SMOCAD2 if '$DATA(ICDCSYS("10D"))
GOTO HBA1
+1 SET C="F17.2"
FOR
SET C=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C))
if (C'?1"F17.2".E)
QUIT
Begin DoDot:1
+2 IF "^200^203^208^209^210^213^218^219^220^223^228^229^290^293^298^299^"'[("^"_$PIECE(C,".",2)_"^")
QUIT
+3 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C,DFN))
if 'DFN
QUIT
Begin DoDot:2
+4 SET E=PXRRSXMO
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C,DFN,E))
if 'E
QUIT
Begin DoDot:3
+5 IF $DATA(^TMP($JOB,PXRRCLIN,"ICD PAT","I25",DFN))
SET PXRRCDSM=PXRRCDSM+1
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT","Z72.0",DFN))
if 'DFN
QUIT
Begin DoDot:1
+7 SET E=PXRRSXMO
FOR
SET E=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT","Z72.0",DFN,E))
if 'E
QUIT
Begin DoDot:2
+8 IF $DATA(^TMP($JOB,PXRRCLIN,"ICD PAT","I25",DFN))
SET PXRRCDSM=PXRRCDSM+1
End DoDot:2
End DoDot:1
HBA1 ; _._._._._._._._._._.HTN AND/OR HBA1C w/ DM DX_._._._._._._._._._._._.
+1 ; **Site Specific Entries for Selected Labs**
+2 SET PX=$ORDER(^PX(815,0))
SET (DFN,PXRRHBA1)=0
SET PXRRLED=(9999999.9999999-PXRRSXMO)
+3 KILL C,C2
if $DATA(ICDCSYS("ICD"))
SET C(250)=""
IF $DATA(ICDCSYS("10D"))
FOR C2="E08","E09","E10","E11","E12","E13"
SET C(C2)=""
+4 SET C2=""
FOR
SET C2=$ORDER(C(C2))
if C2=""
QUIT
Begin DoDot:1
+5 FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C2,DFN))
if 'DFN
QUIT
Begin DoDot:2
+6 SET PXRLRDFN=$PIECE($GET(^DPT(DFN,"LR")),U)
if 'PXRLRDFN
QUIT
SET L=0
FOR
SET L=$ORDER(^PX(815,PX,"RR5",L))
if 'L
QUIT
Begin DoDot:3
+7 SET X=$PIECE(^PX(815,PX,"RR5",L,0),U)
SET X=$PIECE($PIECE(^LAB(60,X,0),U,5),";",2)
SET E=9999999.9999999-DT
FOR
SET E=$ORDER(^LR(PXRLRDFN,"CH",E))
if 'E!(E>PXRRLED)
QUIT
Begin DoDot:4
+8 IF +$PIECE($GET(^LR(PXRLRDFN,"CH",E,X)),U)
Begin DoDot:5
+9 SET PXRRHBA1=PXRRHBA1+$PIECE($GET(^LR(PXRLRDFN,"CH",E,X)),U)
SET ^TMP($JOB,PXRRCLIN,"HBA1C",DFN,E)=$PIECE($GET(^LR(PXRLRDFN,"CH",E,X)),U)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 SET (PXRRHBG7,PXRRHBPT,DFN)=0
+11 FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"HBA1C",DFN))
if 'DFN
QUIT
SET X=0
FOR
SET X=$ORDER(^TMP($JOB,PXRRCLIN,"HBA1C",DFN,X))
if 'X
QUIT
SET PXRRHBPT=PXRRHBPT+1
Begin DoDot:1
+12 IF $GET(^TMP($JOB,PXRRCLIN,"HBA1C",DFN,X))>6.99
IF '$DATA(X(DFN))
SET PXRRHBG7=PXRRHBG7+1
+13 SET X(DFN)=""
End DoDot:1
+14 KILL X
IF $GET(PXRRHBA1)>0
SET PXRRHBA1=PXRRHBA1/PXRRHBPT
+15 if 'PXRRHBPT
SET PXRRHBA1="N/A"
SET PXRRHBG7=0
SXUTTOT ;_._._._._._._._._.Quality Care & Util 7 other Totals_._._._._._._._.
+1 DO ^PXRRPCE4
+2 IF '$DATA(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS"))
SET ^TMP($JOB,PXRRCLIN,"PATIENT","NONE",PXRRCLIN)=""
+3 QUIT
AGE ;_._._._._._._._._._.Calculate a patient's age_._._._._._._._._._.
+1 IF $DATA(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",DFN))
SET X=0
QUIT
+2 DO DEM^VADPT
IF VADM(4)
SET ^TMP($JOB,PXRRCLIN,"PATIENT AGE",VADM(4),DFN)=Z
DO KVAR^VADPT
+3 QUIT
