- 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
