BPXRMPCC ; IHS/MSC/MGH - Computed Findings for PCC reminders. ;16-Feb-2018 16:02;DU
;;2.0;CLINICAL REMINDERS;**1001,1002,1003,1009**;Feb 04, 2005;Build 17
;=================================================================
;This routine is designed to use the standard PCC logic for reminders to
;evaluate if items are met or not met. Using the standard PCC calls ensures
;that all IHS items are using the same logic.
;=====================================================================
ALCOHOL(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for alcohol screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMALCS^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
DEPRESS(DFN,TEST,DATE,VALUE,TEXT) ;EP
;This computed finding will check the PCC logic for depression screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMDEPS^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
FUNCTION(DFN,TEST,DATE,VALUE,TEXT) ;EP
;This computed finding will check the PCC logic for functional screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMAOF^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
DIABETES(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for diabetes screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMGLUC^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
IPVS(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for intimate partner violence screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMIPVS^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
EPSDT(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for EPSDT
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMEPSDT^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
MAMMO(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for mammogram screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMMAMM^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
OSTEO(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for osteoporosis screening
N BPXRESLT,TODAY,X,Y,Z,AGE,DOB
S DOB=$P($G(^DPT(DFN,0)),U,3)
S TODAY=$$DT^XLFDT()
;I $$LASTDX^APCHSMU2(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),TODAY) S TEST=1,VALUE="NA",TEXT="Pt has DX of osteoporosis",DATE=TODAY Q
S BPXRESLT=$$REMOSTEO^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 D
.I $$LASTDX^APCHSMU2(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),TODAY) D
..S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
.E D
..S DATE=$P(BPXRESLT,U,2)
..I DATE'="" D
...S Z=$$AGE^PXRMAGE(DOB,"",DATE)
...I Z>64 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
...E S TEST=0,VALUE=TEST,DATE=$P(BPXRESLT,U,2),TEXT="Test was done before age 65"
..E S TEST=0,VALUE=TEST,DATE=TODAY,TEXT="Unable to determine date of test"
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
PAP(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for pap smear screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMPAP^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
TOBACCO(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for tobacco screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMTOBS^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
HEAR(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for hearing screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMHEAR^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
VISION(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for vision screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMVAE^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
DENTAL(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for dental screening
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$REMDENT^APCLAPIR(DFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
HC(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for head circumference
N BPXRESLT,TODAY,X,Y,APCLPDFN
S TODAY=$$DT^XLFDT()
S APCLPDFN=DFN
S BPXRESLT=$$REMHC^APCLAPIR(APCLPDFN)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE=$P(BPXRESLT,U,4),TEXT=$P(BPXRESLT,U,3),DATE=$P(BPXRESLT,U,2)
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
AMP(DFN,TEST,DATE,VALUE,TEXT) ; EP
;This computed finding will check the PCC logic for bilateral amputation
N BPXRESLT,TODAY,X,Y
S TODAY=$$DT^XLFDT()
S BPXRESLT=$$AMP^BGP4D27(DFN,TODAY)
I $P(BPXRESLT,U,1)=1 S TEST=1,VALUE="BI-LATERAL AMPUTATION",TEXT="Code for bi-lateral amputation found",DATE=TODAY
I $P(BPXRESLT,U,1)=0 S TEST=0,VALUE=TEST,DATE=TODAY
Q
BPXRMPCC ; IHS/MSC/MGH - Computed Findings for PCC reminders. ;16-Feb-2018 16:02;DU
+1 ;;2.0;CLINICAL REMINDERS;**1001,1002,1003,1009**;Feb 04, 2005;Build 17
+2 ;=================================================================
+3 ;This routine is designed to use the standard PCC logic for reminders to
+4 ;evaluate if items are met or not met. Using the standard PCC calls ensures
+5 ;that all IHS items are using the same logic.
+6 ;=====================================================================
ALCOHOL(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for alcohol screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMALCS^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
DEPRESS(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 ;This computed finding will check the PCC logic for depression screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMDEPS^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
FUNCTION(DFN,TEST,DATE,VALUE,TEXT) ;EP
+1 ;This computed finding will check the PCC logic for functional screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMAOF^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
DIABETES(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for diabetes screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMGLUC^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
IPVS(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for intimate partner violence screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMIPVS^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
EPSDT(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for EPSDT
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMEPSDT^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
MAMMO(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for mammogram screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMMAMM^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
OSTEO(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for osteoporosis screening
+2 NEW BPXRESLT,TODAY,X,Y,Z,AGE,DOB
+3 SET DOB=$PIECE($GET(^DPT(DFN,0)),U,3)
+4 SET TODAY=$$DT^XLFDT()
+5 ;I $$LASTDX^APCHSMU2(DFN,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),TODAY) S TEST=1,VALUE="NA",TEXT="Pt has DX of osteoporosis",DATE=TODAY Q
+6 SET BPXRESLT=$$REMOSTEO^APCLAPIR(DFN)
+7 IF $PIECE(BPXRESLT,U,1)=1
Begin DoDot:1
+8 IF $$LASTDX^APCHSMU2(DFN,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),TODAY)
Begin DoDot:2
+9 SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 SET DATE=$PIECE(BPXRESLT,U,2)
+12 IF DATE'=""
Begin DoDot:3
+13 SET Z=$$AGE^PXRMAGE(DOB,"",DATE)
+14 IF Z>64
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+15 IF '$TEST
SET TEST=0
SET VALUE=TEST
SET DATE=$PIECE(BPXRESLT,U,2)
SET TEXT="Test was done before age 65"
End DoDot:3
+16 IF '$TEST
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
SET TEXT="Unable to determine date of test"
End DoDot:2
End DoDot:1
+17 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+18 QUIT
PAP(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for pap smear screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMPAP^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
TOBACCO(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for tobacco screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMTOBS^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
HEAR(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for hearing screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMHEAR^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
VISION(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for vision screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMVAE^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
DENTAL(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for dental screening
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$REMDENT^APCLAPIR(DFN)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
HC(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for head circumference
+2 NEW BPXRESLT,TODAY,X,Y,APCLPDFN
+3 SET TODAY=$$DT^XLFDT()
+4 SET APCLPDFN=DFN
+5 SET BPXRESLT=$$REMHC^APCLAPIR(APCLPDFN)
+6 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE=$PIECE(BPXRESLT,U,4)
SET TEXT=$PIECE(BPXRESLT,U,3)
SET DATE=$PIECE(BPXRESLT,U,2)
+7 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+8 QUIT
AMP(DFN,TEST,DATE,VALUE,TEXT) ; EP
+1 ;This computed finding will check the PCC logic for bilateral amputation
+2 NEW BPXRESLT,TODAY,X,Y
+3 SET TODAY=$$DT^XLFDT()
+4 SET BPXRESLT=$$AMP^BGP4D27(DFN,TODAY)
+5 IF $PIECE(BPXRESLT,U,1)=1
SET TEST=1
SET VALUE="BI-LATERAL AMPUTATION"
SET TEXT="Code for bi-lateral amputation found"
SET DATE=TODAY
+6 IF $PIECE(BPXRESLT,U,1)=0
SET TEST=0
SET VALUE=TEST
SET DATE=TODAY
+7 QUIT
