PXRRPCE4 ;HIN/MjK - Clinic Specific Caseload Demographics ;6/7/96
;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
LDL ;_._._._._._._._._._._._._._.LDL w/ CAD DX _._._._._.__._._._._._._._.
; **Site Specific IENS from Laboratory Test file**
;E=lab dt ;L=lab test ifn ;V=ldl value
S PX=$O(^PX(815,0))
S C=414,(PXRRLDL,PXRRDFN,PXRRCDSX,PXRRLDPT)=0 F S PXRRDFN=$O(^TMP($J,PXRRCLIN,"ICD PAT",C,PXRRDFN)) Q:'PXRRDFN S PXRRCDSX=PXRRCDSX+1,PXRLRDFN=+$G(^DPT(PXRRDFN,"LR")) Q:'PXRLRDFN S E=0 F S E=$O(^LR(PXRLRDFN,"CH",E)) Q:'E!(E>PXRRLED) D
. S X=0 F S X=$O(^PX(815,PX,"RR4",X)) Q:'X S L=$P(^PX(815,PX,"RR4",X,0),U),L=$P($P(^LAB(60,L,0),U,5),";",2) I $D(^LR(PXRLRDFN,"CH",E,L)) D
.. S V=+$P($G(^LR(PXRLRDFN,"CH",E,L)),U)
.. S PXRRLDL=PXRRLDL+V
.. S:+V PXRRLDPT=PXRRLDPT+1,^TMP($J,"LDL",PXRRDFN,E)=V
.. S:'+V ^TMP($J,"LDL NO VAL",PXRRDFN,E)=V
I $G(PXRRLDL)>0 S PXRRLDL=PXRRLDL/PXRRLDPT
;_._.CAD pats with no LDL values_._.
S (PXRRNOLD,PXRRDFN)=0 F S PXRRDFN=$O(^TMP($J,"ICD PAT",C,PXRRDFN)) Q:'PXRRDFN I '$D(^TMP($J,"LDL",PXRRDFN)) S PXRRNOLD=PXRRNOLD+1
I '+PXRRLDPT S PXRRLDL="N/A"
TOTPATS ;_._._._._._._._._.Patient Totals - Pats by Gender_._._._._._._._._.
S PRX=0 F S PRX=$O(^TMP($J,PXRRCLIN,"CLINIC PATIENTS",PRX)) Q:'PRX S PXRRTPAT=PXRRTPAT+1 S DFN=PRX D DEM^VADPT K DFN I $P(VADM(5),U)="M" S PXRRMPAT=PXRRMPAT+1
S PXRRFPAT=PXRRTPAT-PXRRMPAT,PXRRRTVS=0,X=0,Y="" F S X=$O(^TMP($J,PXRRCLIN,"PATIENT APPTS",X)) Q:'X S PXRRDFN=0 F S PXRRDFN=$O(^TMP($J,PXRRCLIN,"PATIENT APPTS",X,PXRRDFN)) Q:'PXRRDFN D
. S:(X>PXRRBDT)&'($D(X(PXRRDFN))) PXRRVPAT=PXRRVPAT+1,X(PXRRDFN)=""
. S:(X'<PXRRSXMO)&('$D(Y(PXRRDFN))) PXRRQPAT=PXRRQPAT+1,Y(PXRRDFN)=""
. S:X'>PXRREDT&(X>PXRRBDT) PXRRRTVS=PXRRRTVS+1
K X,Y S PXRRPTSS=PXRRRTVS/PXRRSESS
QLM ;_._._._._._._._._.QLM Unsched, ER, Hospztns_._._._._._._._._.
; ** Site Specific Clinic IENs from file 44**
S PX=$O(^PX(815,0)),(DFN,PXRRSXER,PXRRSXHP)=0 F S DFN=$O(^TMP($J,PXRRCLIN,"CLINIC PATIENTS",DFN)) Q:'DFN D
. S Y=0 F S Y=$O(^PX(815,PX,"RR1",Y)) Q:'Y S PXRRER=$P(^(Y,0),U),VASD("C",PXRRER)=""
. S VASD("F")=PXRRBDT,VASD("T")=PXRRSXMO D SDA^VADPT S X=0 F S X=$O(^UTILITY("VASD",$J,X)) Q:'X S PXRRSXER=PXRRSXER+1
. S PXRRDIFF=$$FMDIFF^XLFDT(PXRRBDT,PXRRSXMO) F PXR=0:1:PXRRDIFF S VAINDT=$$FMADD^XLFDT(PXRRBDT,PXR) D ADM^VADPT2 I $G(VADMVT)'="" S:'$D(PXR(VADMVT)) PXRRSXHP=PXRRSXHP+1 S PXR(VADMVT)="" K VADMVT
K PXR
PERQPAT I PXRRQPAT>0 F PXRR="PXRRSXUN","PXRRSXER","PXRRSXHP" S Y=@PXRR S PXRR(PXRR)=$S('Y:0,1:(Y/PXRRQPAT))
MAMGRM ;_._._._._._._._._._Mammograms for Patients >= 50 _._._._._.__._._.
;PXRRA = Age in years ;B= Radiology Date ;C = Inv. Radiology Date
;E = IEN2 RADIOLOGY PATIENT
S (PXRRF50,PXRRMMYR)=0,PXRRA=49.9
F S PXRRA=$O(^TMP($J,PXRRCLIN,"PATIENT AGE",PXRRA)) Q:'PXRRA S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"PATIENT AGE",PXRRA,DFN)) Q:'DFN D DEM^VADPT I $P(VADM(5),U)="F" S PXRRF50=PXRRF50+1 I $D(^RADPT(DFN)) D
. S B=PXRRBDT F S B=$O(^RADPT(DFN,"DT",B)) Q:'B!((9999999.9999999-B)<PXRRYR) S E=0 F S E=$O(^RADPT(DFN,"DT",B,"P",E)) Q:'E D:'$D(E(DFN))
.. S PXRRMAMG=$P($G(^RADPT(DFN,"DT",B,"P",E,0)),U,2) I PXRRMAMG F X=76090:1:76092 S:$D(^RAMIS(71,"D",X,PXRRMAMG)) PXRRMMYR=PXRRMMYR+1,^TMP($J,PXRRCLIN,">=50 W MM",DFN,B)="",E(DFN)=""
K E
CRITLAB ;_._._._._._._._._._._.Critical Lab Values_._._._._._._._._._._._.
;X = Lab Fields E = Lab Date ;C = Chol Value G = Glucose Value
S (PXRRDFN,PXRRGL,PXRRCHOL)=0
F S PXRRDFN=$O(^TMP($J,PXRRCLIN,"CLINIC PATIENTS",PXRRDFN)) Q:'PXRRDFN S PXRLRDFN=+$G(^DPT(PXRRDFN,"LR")) Q:'PXRLRDFN S L=0 F S L=$O(^PX(815,PX,"RR2",L)) Q:'L S X=$P(^(L,0),U),X=$P($P(^LAB(60,X,0),U,5),";",2) D
GLU . ;_.Glucose
. S E=0 F S E=$O(^LR(PXRLRDFN,"CH",E)) Q:'E!(E>PXRRLED) S C=+$P($G(^LR(PXRLRDFN,"CH",E,+X)),U) S:C>200&('$D(^TMP($J,PXRRCLIN,"GL",PXRRDFN))) PXRRGL=PXRRGL+1,^TMP($J,PXRRCLIN,"GL",PXRRDFN,C,E)=""
CHOL . ;_.Cholesterol
. S L=0 F S L=$O(^PX(815,PX,"RR3",L)) Q:'L S X=$P(^(L,0),U),X=$P($P(^LAB(60,X,0),U,5),";",2) D
.. F S E=$O(^LR(PXRLRDFN,"CH",E)) Q:'E!(E>PXRRLED) S G=+$P($G(^LR(PXRLRDFN,"CH",E,+X)),U) S:G>240&('$D(^TMP($J,PXRRCLIN,"CHOL",PXRRDFN))) PXRRCHOL=PXRRCHOL+1,^TMP($J,PXRRCLIN,"CHOL",PXRRDFN,G,E)=""
UTIL ;._._._._._._._._._._._._.Utilization Data_._._._._._._._._._._._.
S DFN=0 F S DFN=$O(^TMP($J,PXRRCLIN,"CLINIC PATIENTS",DFN)) Q:'DFN D
. S PSOACT=1 D ^PSOHCSUM S PXRRPSO=0 F S PXRRPSO=$O(^TMP("PSOO",$J,PXRRPSO)) Q:'PXRRPSO I $P($P(^TMP("PSOO",$J,PXRRPSO,0),U,5),";",2)="ACTIVE" S PXRRPSUT=PXRRPSUT+1,PXRRCOST=PXRRCOST+$P(^TMP("PSOO",$J,PXRRPSO,0),U,10)
. K ^TMP("PSOO",$J)
S PXRRUTVS=PXRRTVS/PXRRTPAT,PXRRUTVS=$J(PXRRUTVS,2,1)
PERUPAT I PXRRTPAT>0 F PXRR="PXRRPSUT","PXRRCOST" S Y=@PXRR S PXRR(PXRR)=$S('Y:0,1:(Y/PXRRTPAT))
PCE5 ;_._._._._._._._._._._._.Call PXRRPCE5_._._._._._._._._._._._.
D ^PXRRPCE5
Q
PXRRPCE4 ;HIN/MjK - Clinic Specific Caseload Demographics ;6/7/96
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
LDL ;_._._._._._._._._._._._._._.LDL w/ CAD DX _._._._._.__._._._._._._._.
+1 ; **Site Specific IENS from Laboratory Test file**
+2 ;E=lab dt ;L=lab test ifn ;V=ldl value
+3 SET PX=$ORDER(^PX(815,0))
+4 SET C=414
SET (PXRRLDL,PXRRDFN,PXRRCDSX,PXRRLDPT)=0
FOR
SET PXRRDFN=$ORDER(^TMP($JOB,PXRRCLIN,"ICD PAT",C,PXRRDFN))
IF 'PXRRDFN
QUIT
SET PXRRCDSX=PXRRCDSX+1
SET PXRLRDFN=+$GET(^DPT(PXRRDFN,"LR"))
IF 'PXRLRDFN
QUIT
SET E=0
FOR
SET E=$ORDER(^LR(PXRLRDFN,"CH",E))
IF 'E!(E>PXRRLED)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^PX(815,PX,"RR4",X))
IF 'X
QUIT
SET L=$PIECE(^PX(815,PX,"RR4",X,0),U)
SET L=$PIECE($PIECE(^LAB(60,L,0),U,5),";",2)
IF $DATA(^LR(PXRLRDFN,"CH",E,L))
Begin DoDot:2
+6 SET V=+$PIECE($GET(^LR(PXRLRDFN,"CH",E,L)),U)
+7 SET PXRRLDL=PXRRLDL+V
+8 IF +V
SET PXRRLDPT=PXRRLDPT+1
SET ^TMP($JOB,"LDL",PXRRDFN,E)=V
+9 IF '+V
SET ^TMP($JOB,"LDL NO VAL",PXRRDFN,E)=V
End DoDot:2
End DoDot:1
+10 IF $GET(PXRRLDL)>0
SET PXRRLDL=PXRRLDL/PXRRLDPT
+11 ;_._.CAD pats with no LDL values_._.
+12 SET (PXRRNOLD,PXRRDFN)=0
FOR
SET PXRRDFN=$ORDER(^TMP($JOB,"ICD PAT",C,PXRRDFN))
IF 'PXRRDFN
QUIT
IF '$DATA(^TMP($JOB,"LDL",PXRRDFN))
SET PXRRNOLD=PXRRNOLD+1
+13 IF '+PXRRLDPT
SET PXRRLDL="N/A"
TOTPATS ;_._._._._._._._._.Patient Totals - Pats by Gender_._._._._._._._._.
+1 SET PRX=0
FOR
SET PRX=$ORDER(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",PRX))
IF 'PRX
QUIT
SET PXRRTPAT=PXRRTPAT+1
SET DFN=PRX
DO DEM^VADPT
KILL DFN
IF $PIECE(VADM(5),U)="M"
SET PXRRMPAT=PXRRMPAT+1
+2 SET PXRRFPAT=PXRRTPAT-PXRRMPAT
SET PXRRRTVS=0
SET X=0
SET Y=""
FOR
SET X=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT APPTS",X))
IF 'X
QUIT
SET PXRRDFN=0
FOR
SET PXRRDFN=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT APPTS",X,PXRRDFN))
IF 'PXRRDFN
QUIT
Begin DoDot:1
+3 IF (X>PXRRBDT)&'($DATA(X(PXRRDFN)))
SET PXRRVPAT=PXRRVPAT+1
SET X(PXRRDFN)=""
+4 IF (X'<PXRRSXMO)&('$DATA(Y(PXRRDFN)))
SET PXRRQPAT=PXRRQPAT+1
SET Y(PXRRDFN)=""
+5 IF X'>PXRREDT&(X>PXRRBDT)
SET PXRRRTVS=PXRRRTVS+1
End DoDot:1
+6 KILL X,Y
SET PXRRPTSS=PXRRRTVS/PXRRSESS
QLM ;_._._._._._._._._.QLM Unsched, ER, Hospztns_._._._._._._._._.
+1 ; ** Site Specific Clinic IENs from file 44**
+2 SET PX=$ORDER(^PX(815,0))
SET (DFN,PXRRSXER,PXRRSXHP)=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+3 SET Y=0
FOR
SET Y=$ORDER(^PX(815,PX,"RR1",Y))
IF 'Y
QUIT
SET PXRRER=$PIECE(^(Y,0),U)
SET VASD("C",PXRRER)=""
+4 SET VASD("F")=PXRRBDT
SET VASD("T")=PXRRSXMO
DO SDA^VADPT
SET X=0
FOR
SET X=$ORDER(^UTILITY("VASD",$JOB,X))
IF 'X
QUIT
SET PXRRSXER=PXRRSXER+1
+5 SET PXRRDIFF=$$FMDIFF^XLFDT(PXRRBDT,PXRRSXMO)
FOR PXR=0:1:PXRRDIFF
SET VAINDT=$$FMADD^XLFDT(PXRRBDT,PXR)
DO ADM^VADPT2
IF $GET(VADMVT)'=""
IF '$DATA(PXR(VADMVT))
SET PXRRSXHP=PXRRSXHP+1
SET PXR(VADMVT)=""
KILL VADMVT
End DoDot:1
+6 KILL PXR
PERQPAT IF PXRRQPAT>0
FOR PXRR="PXRRSXUN","PXRRSXER","PXRRSXHP"
SET Y=@PXRR
SET PXRR(PXRR)=$SELECT('Y:0,1:(Y/PXRRQPAT))
MAMGRM ;_._._._._._._._._._Mammograms for Patients >= 50 _._._._._.__._._.
+1 ;PXRRA = Age in years ;B= Radiology Date ;C = Inv. Radiology Date
+2 ;E = IEN2 RADIOLOGY PATIENT
+3 SET (PXRRF50,PXRRMMYR)=0
SET PXRRA=49.9
+4 FOR
SET PXRRA=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT AGE",PXRRA))
IF 'PXRRA
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"PATIENT AGE",PXRRA,DFN))
IF 'DFN
QUIT
DO DEM^VADPT
IF $PIECE(VADM(5),U)="F"
SET PXRRF50=PXRRF50+1
IF $DATA(^RADPT(DFN))
Begin DoDot:1
+5 SET B=PXRRBDT
FOR
SET B=$ORDER(^RADPT(DFN,"DT",B))
IF 'B!((9999999.9999999-B)<PXRRYR)
QUIT
SET E=0
FOR
SET E=$ORDER(^RADPT(DFN,"DT",B,"P",E))
IF 'E
QUIT
IF '$DATA(E(DFN))
Begin DoDot:2
+6 SET PXRRMAMG=$PIECE($GET(^RADPT(DFN,"DT",B,"P",E,0)),U,2)
IF PXRRMAMG
FOR X=76090:1:76092
IF $DATA(^RAMIS(71,"D",X,PXRRMAMG))
SET PXRRMMYR=PXRRMMYR+1
SET ^TMP($JOB,PXRRCLIN,">=50 W MM",DFN,B)=""
SET E(DFN)=""
End DoDot:2
End DoDot:1
+7 KILL E
CRITLAB ;_._._._._._._._._._._.Critical Lab Values_._._._._._._._._._._._.
+1 ;X = Lab Fields E = Lab Date ;C = Chol Value G = Glucose Value
+2 SET (PXRRDFN,PXRRGL,PXRRCHOL)=0
+3 FOR
SET PXRRDFN=$ORDER(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",PXRRDFN))
IF 'PXRRDFN
QUIT
SET PXRLRDFN=+$GET(^DPT(PXRRDFN,"LR"))
IF 'PXRLRDFN
QUIT
SET L=0
FOR
SET L=$ORDER(^PX(815,PX,"RR2",L))
IF 'L
QUIT
SET X=$PIECE(^(L,0),U)
SET X=$PIECE($PIECE(^LAB(60,X,0),U,5),";",2)
Begin DoDot:1
GLU ;_.Glucose
+1 SET E=0
FOR
SET E=$ORDER(^LR(PXRLRDFN,"CH",E))
IF 'E!(E>PXRRLED)
QUIT
SET C=+$PIECE($GET(^LR(PXRLRDFN,"CH",E,+X)),U)
IF C>200&('$DATA(^TMP($JOB,PXRRCLIN,"GL",PXRRDFN)))
SET PXRRGL=PXRRGL+1
SET ^TMP($JOB,PXRRCLIN,"GL",PXRRDFN,C,E)=""
CHOL ;_.Cholesterol
+1 SET L=0
FOR
SET L=$ORDER(^PX(815,PX,"RR3",L))
IF 'L
QUIT
SET X=$PIECE(^(L,0),U)
SET X=$PIECE($PIECE(^LAB(60,X,0),U,5),";",2)
Begin DoDot:2
+2 FOR
SET E=$ORDER(^LR(PXRLRDFN,"CH",E))
IF 'E!(E>PXRRLED)
QUIT
SET G=+$PIECE($GET(^LR(PXRLRDFN,"CH",E,+X)),U)
IF G>240&('$DATA(^TMP($JOB,PXRRCLIN,"CHOL",PXRRDFN)))
SET PXRRCHOL=PXRRCHOL+1
SET ^TMP($JOB,PXRRCLIN,"CHOL",PXRRDFN,G,E)=""
End DoDot:2
End DoDot:1
UTIL ;._._._._._._._._._._._._.Utilization Data_._._._._._._._._._._._.
+1 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,PXRRCLIN,"CLINIC PATIENTS",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+2 SET PSOACT=1
DO ^PSOHCSUM
SET PXRRPSO=0
FOR
SET PXRRPSO=$ORDER(^TMP("PSOO",$JOB,PXRRPSO))
IF 'PXRRPSO
QUIT
IF $PIECE($PIECE(^TMP("PSOO",$JOB,PXRRPSO,0),U,5),";",2)="ACTIVE"
SET PXRRPSUT=PXRRPSUT+1
SET PXRRCOST=PXRRCOST+$PIECE(^TMP("PSOO",$JOB,PXRRPSO,0),U,10)
+3 KILL ^TMP("PSOO",$JOB)
End DoDot:1
+4 SET PXRRUTVS=PXRRTVS/PXRRTPAT
SET PXRRUTVS=$JUSTIFY(PXRRUTVS,2,1)
PERUPAT IF PXRRTPAT>0
FOR PXRR="PXRRPSUT","PXRRCOST"
SET Y=@PXRR
SET PXRR(PXRR)=$SELECT('Y:0,1:(Y/PXRRTPAT))
PCE5 ;_._._._._._._._._._._._.Call PXRRPCE5_._._._._._._._._._._._.
+1 DO ^PXRRPCE5
+2 QUIT
