BGP1CPU2 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 9:24 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
WNMIACE ;EP - write out nmi ACE/ARB
I '$D(BGPDATA) D Q
.I $Y>(BGPIOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !!?2,"NMI Refusal? No"
.I BGPACPT]"" W !!?4,"CPT: ",BGPACPT
I $Y>(BGPIOSL-6) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"NMI Refusal: Yes"
;NEW Y S Y=0 F S Y=$O(BGPDATA(Y)) Q:Y'=+Y D
S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(IOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !?4,BGPDATA(BGPXX)
;W !?4,BGPDATA(Y)
I $Y>(BGPIOSL-6) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
I BGPACPT]"" W !!?4,"CPT: ",BGPACPT
W !,"NOTE: The patient's chart needs to be reviewed to determine if this was"
W !,"documented by a physician/APN/PA before it is used to exclude patients"
W !,"from the denominator."
Q
WLVS ;EP write out lvs FUNCTION
S X=0,C=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"Evaluation of LVS Function? "
;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(IOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !?4,BGPDATA(BGPXX)
;W !?4,BGPDATA(X)
;W !
Q
WDSCHINT ;EP - write out discharge instructions
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"Discharge Instructions? ",BGPPED,!
Q
WLVAD ;EP
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,$S(BGPPEX[1:"*",1:""),"LVAD/Heart Transplant? ",BGPLVAD
Q
WCOMFORT(X) ;EP - write out comfort message
I X="" D Q
.I $Y>(BGPIOSL-4) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !!?2,"Comfort Measures? None Recorded."
I $Y>(BGPIOSL-5) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"Comfort Measures? ",X
W !,"NOTE: The patient's chart needs to be reviewed to determine if"
W !,"this was documented by a physician/APN/PA before it is used"
W !,"to exclude patients from the denominator. "
Q
;
WDOD(V) ;EP - write dod
I $Y>(BGPIOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
I $$DOD^AUPNPAT(V)]"" D
.W !!?2,"*Date of Death: ",$$DATE^BGP1UTL($$DOD^AUPNPAT(V))
Q
;
WDT(V) ;EP - write discharge type at column 3
I $Y>(BGPIOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W:'$D(BGPNOBA) ! W !?2,$S(BGPPEX[2:"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
Q
;
WTT(V) ;EP - write transferred to
I $Y>(BGPIOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W:'$D(BGPNOBA) ! W !?2,"Transferred to: ",$$VAL^XBDIQ1(9000010.02,V,.09)
Q
;
WPPDPOV(V) ;EP
I $Y>(BGPIOSL-2) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W:'$D(BGPNOBA) ! W !?2,"Primary Discharge POV: "_$$PRIMPOV^APCLV(V,"C")," ",$$PRIMPOV^APCLV(V,"N")
Q
;
OTHDPOVS(V) ;EP write out other discharge povs
NEW X,C
S (X,C)=0 F S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X D
.Q:'$D(^AUPNVPOV(X,0))
.Q:$P(^AUPNVPOV(X,0),U,12)="P"
.S C=C+1
.Q
I $Y>(BGPIOSL-(C+2)) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"Other Discharge POVs for this visit:",$S(C=0:" None",1:"")
S (X,C)=0 F S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X D
.Q:'$D(^AUPNVPOV(X,0))
.Q:$P(^AUPNVPOV(X,0),U,12)="P"
.S C=C+1
.S I=$P(^AUPNVPOV(X,0),U),I=$P($$ICDDX^ICDCODE(I),U,2)
.S N=$$VAL^XBDIQ1(9000010.07,X,.04),N=$$UP^XLFSTR(N)
.W !?4,I,?11,N
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:80)-$L(X)\2)_X
;
WPCI ;EP write out
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"PCI: "
W ?4,BGPPCI
Q:BGPPCI="" ;only display note if found procedure
I $Y>(BGPIOSL-5) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: For this to be used to exclude patients from the denominator, it must "
W !,"be described as non-primary by a physician/APN/PA. For this to be used to "
W !,"include patients in the numerator, the PCI must be performed within 90 "
W !,"minutes of hospital arrival. The patient's chart must be reviewed to make"
W !,"these determinations.",!
Q
;
WFIB ;EP - write out fib meds
S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
S X=0 F S X=$O(BGPUD(X)) Q:X'=+X S Y=0 F S Y=$O(BGPUD(X,Y)) Q:Y'=+Y S C=C+1
I $Y>(BGPIOSL-(C+2)) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"Fibronolytic Therapy Rx Status? "
I $D(BGPDATA) W !?4,"Outpatient Rx: " D
.S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX!(BGPQUIT) D
..K BGPLETXT S BGPLETP("ICL")=0,BGPLETP("LGTH")=70,BGPLETP("NRQ")=BGPDATA(BGPXX),BGPLETP("TXT")="",BGPLEC=0
..D GETTXT^BGP1CPU4
..S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
...D:$Y>(BGPIOSL-3) HDR^BGP1CP Q:BGPQUIT W !?4,BGPLETXT(BGPZZ)
;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
I $D(BGPUD) W !?4,"IV/Unit Dose: " W BGPUD D
.S BGPXX=0 F S BGPXX=$O(BGPUD(BGPXX)) Q:BGPXX'=+BGPXX!(BGPQUIT) D
..K BGPLETXT S BGPLETP("ICL")=0,BGPLETP("LGTH")=70,BGPLETP("NRQ")=BGPUD(BGPXX),BGPLETP("TXT")="",BGPLEC=0
..D GETTXT^BGP1CPU4
..S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
...D:$Y>(BGPIOSL-3) HDR^BGP1CP Q:BGPQUIT W !?4,BGPLETXT(BGPZZ)
;S X=0 F S X=$O(BGPUD(X)) Q:X'=+X W !?4,BGPUD(X)
I BGPTAPRO]"" W !?4,"Procedure: ",BGPTAPRO
I '$D(BGPDATA),'$D(BGPUD),BGPTAPRO="" Q ;no data so no note
I $Y>(BGPIOSL-4) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: In order to be included in the numerator, the therapy must have been"
W !,"received within 30 minutes or less from hospital arrival. The patient's"
W !,"chart must be reviewed to make this determination.",!
Q
WLBBB ;EP - write out lbbb on ecg
I $Y>(BGPIOSL-6) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"LBBB on ECG: "
W !?4,BGPLBDX
S X=0 F S X=$O(BGPLBPC(X)) Q:X'=+X W !?4,BGPLBPC(X)
I BGPLBDX="",'$D(BGPLBPC) Q ;no note if no data
W !,"NOTE: The patient's chart needs to be reviewed to determine if other"
W !,"ST-Segment Elevations or LBBB on ECGs are noted and which was performed"
W !,"closest to hospital arrival."
Q
WST ;EP write out st segment elevation
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"ST-Segment Elevation: "
W ?4,BGPST1
I BGPST1="" Q
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: The patient's chart needs to be reviewed to determine if other"
W !,"ST-Segment Elevations or LBBB on ECGs are noted and which was performed"
W !,"closest to hospital arrival."
Q
WCS ;EP -write out circulatory shock
I $Y>(BGPIOSL-6) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,$S(BGPPEX["B":"*",1:""),"Circulatory Shock? "
I '$D(BGPDATA) W " No, Not recorded" Q
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
W !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
W !,"should be excluded if circulatory shock occurred on on arrival or within 24"
W !,"hours after arrival."
Q
WHF ;EP - write out HF diagnosis
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,$S(BGPPEX["A":"*",1:""),"Heart Failure? "
I '$D(BGPDATA) W " No, Not recorded" Q
;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !?4,BGPDATA(BGPXX)
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
W !,"should be excluded if heart failure occurred on on arrival or within 24 "
W !,"hours after arrival."
Q
W23RD ;EP write out 2/3 degree
I $Y>(BGPIOSL-5) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,"2nd/3rd Degree heart Block? "
I '$D(BGP23RD) W " No, Not recorded"
I $D(BGP23RD),'BGPPACE W " Yes. "
I $D(BGP23RD),BGPPACE W " Yes, but pacemaker present " ;D
;.S X=0 F S X=$O(BGP23RD(X)) Q:X'=+X W !?4,BGP23RD(X)
I $D(BGP23RD) S X=0 F S X=$O(BGP23RD(X)) Q:X'=+X W !?4,BGP23RD(X)
I '$D(BGP23RD) Q
I $Y>(BGPIOSL-6) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
W !,"should be excluded if the patient has a 2nd/3rd degree heart block "
W !,"on ECG during stay AND does not have a pacemaker (also see Pacemaker"
W !,"below)."
PACE ;
W !!?2,"Pacemaker? ",$S($P(BGPPACE,U,2)]"":$P(BGPPACE,U,2),1:"No, Not recorded")
Q
;
WBRADY6 ;EP write out bradycardia data
I $Y>(BGPIOSL-4) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,$S(BGPPEX[9:"*",1:""),"Bradycardia? "
I '$D(BGPBRADY) W " No, Not recorded" Q
S BGPXX=0 F S BGPXX=$O(BGPBRADY(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !?4,BGPBRADY(BGPXX)
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
W !,"should be excluded if bradycardia occurred on arrival or within"
W !,"24 hours after arrival AND if patient was not on a beta blocker at"
W !,"the time of bradycardia (also see Beta Blocker Rx Status below)."
Q
WBRADY5 ;EP write out bradycardia data
I $Y>(BGPIOSL-4) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !!?2,$S(BGPPEX[9:"*",1:""),"Bradycardia? "
I '$D(BGPBRADY) W " No, Not recorded" Q
S BGPXX=0 F S BGPXX=$O(BGPBRADY(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
.W !?4,BGPBRADY(BGPXX)
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !,"NOTE: The patient's chart needs to be reviewed to determine if the"
W !,"patient should be excluded if bradycardia occurred on day of discharge"
W !,"or day prior to discharge AND if patient was not on a beta blocker at"
W !,"the time of bradycardia (also see Beta Blocker Rx Status below)."
Q
WPRINPRO ;EP
K BGPXX
S BGPC=""
S BGPB=(9999999-$$DSCH^BGP1CU(BGPVINP))-1,BGPE=9999999-$P($P(^AUPNVSIT(BGPVSIT,0),U),".")
F S BGPB=$O(^AUPNVPRC("AA",DFN,BGPB)) Q:BGPB'=+BGPB!(BGPB>BGPE) D
.S X=0 F S X=$O(^AUPNVPRC("AA",DFN,BGPB,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..Q:$P(^AUPNVPRC(X,0),U,7)'="Y"
..S BGPC=$$VAL^XBDIQ1(9000010.08,X,.01)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
I $Y>(BGPIOSL-3) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !?2,"Principle Procedure: ",BGPC
Q
WOTHPROS ;EP
K BGPXX
S BGPC=0
S BGPB=(9999999-$$DSCH^BGP1CU(BGPVINP))-1,BGPE=9999999-$P($P(^AUPNVSIT(BGPVSIT,0),U),".")
F S BGPB=$O(^AUPNVPRC("AA",DFN,BGPB)) Q:BGPB'=+BGPB!(BGPB>BGPE) D
.S X=0 F S X=$O(^AUPNVPRC("AA",DFN,BGPB,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S V=$P(^AUPNVPRC(X,0),U,3)
..Q:'$D(^AUPNVSIT(V,0))
..Q:"IH"'[$P(^AUPNVSIT(V,0),U,7)
..Q:$P(^AUPNVPRC(X,0),U,7)="Y"
..S BGPC=BGPC+1,BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.08,X,.01)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,Y,D,V
S BGPB=9999999-$$DSCH^BGP1CU(BGPVINP),BGPE=9999999-$P($P(^AUPNVSIT(BGPVSIT,0),U),".")
F S BGPB=$O(^AUPNVSIT("AA",DFN,BGPB)) Q:BGPB=""!($P(BGPB,".")>BGPE) D
.S V=0 F S V=$O(^AUPNVSIT("AA",DFN,BGPB,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..Q:"IH"'[$P(^AUPNVSIT(V,0),U,7)
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S BGPC=BGPC+1,BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.18,X,.01)_" "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-BGPB)),U,3)
...Q
..Q
.Q
S (C,X)=0 F S X=$O(BGPXX(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+3)) D HDR^BGP1CP Q:BGPQUIT D L1H^BGP1CP
W !?2,"Other Procedures for this Visit:"
S BGPX=0 F S BGPX=$O(BGPXX(BGPX)) Q:BGPX'=+BGPX W !?4,BGPXX(BGPX)
Q
;
BGP1CPU2 ; IHS/CMI/LAB - calc CMS measures 02 Jul 2010 9:24 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
WNMIACE ;EP - write out nmi ACE/ARB
+1 IF '$DATA(BGPDATA)
Begin DoDot:1
+2 IF $Y>(BGPIOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+3 WRITE !!?2,"NMI Refusal? No"
+4 IF BGPACPT]""
WRITE !!?4,"CPT: ",BGPACPT
End DoDot:1
QUIT
+5 IF $Y>(BGPIOSL-6)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+6 WRITE !!?2,"NMI Refusal: Yes"
+7 ;NEW Y S Y=0 F S Y=$O(BGPDATA(Y)) Q:Y'=+Y D
+8 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+10 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+11 ;W !?4,BGPDATA(Y)
+12 IF $Y>(BGPIOSL-6)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+13 IF BGPACPT]""
WRITE !!?4,"CPT: ",BGPACPT
+14 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if this was"
+15 WRITE !,"documented by a physician/APN/PA before it is used to exclude patients"
+16 WRITE !,"from the denominator."
+17 QUIT
WLVS ;EP write out lvs FUNCTION
+1 SET X=0
SET C=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+3 WRITE !!?2,"Evaluation of LVS Function? "
+4 ;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
+5 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+7 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+8 ;W !?4,BGPDATA(X)
+9 ;W !
+10 QUIT
WDSCHINT ;EP - write out discharge instructions
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,"Discharge Instructions? ",BGPPED,!
+3 QUIT
WLVAD ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,$SELECT(BGPPEX[1:"*",1:""),"LVAD/Heart Transplant? ",BGPLVAD
+3 QUIT
WCOMFORT(X) ;EP - write out comfort message
+1 IF X=""
Begin DoDot:1
+2 IF $Y>(BGPIOSL-4)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+3 WRITE !!?2,"Comfort Measures? None Recorded."
End DoDot:1
QUIT
+4 IF $Y>(BGPIOSL-5)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+5 WRITE !!?2,"Comfort Measures? ",X
+6 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if"
+7 WRITE !,"this was documented by a physician/APN/PA before it is used"
+8 WRITE !,"to exclude patients from the denominator. "
+9 QUIT
+10 ;
WDOD(V) ;EP - write dod
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 IF $$DOD^AUPNPAT(V)]""
Begin DoDot:1
+3 WRITE !!?2,"*Date of Death: ",$$DATE^BGP1UTL($$DOD^AUPNPAT(V))
End DoDot:1
+4 QUIT
+5 ;
WDT(V) ;EP - write discharge type at column 3
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 IF '$DATA(BGPNOBA)
WRITE !
WRITE !?2,$SELECT(BGPPEX[2:"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
+3 QUIT
+4 ;
WTT(V) ;EP - write transferred to
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 IF '$DATA(BGPNOBA)
WRITE !
WRITE !?2,"Transferred to: ",$$VAL^XBDIQ1(9000010.02,V,.09)
+3 QUIT
+4 ;
WPPDPOV(V) ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 IF '$DATA(BGPNOBA)
WRITE !
WRITE !?2,"Primary Discharge POV: "_$$PRIMPOV^APCLV(V,"C")," ",$$PRIMPOV^APCLV(V,"N")
+3 QUIT
+4 ;
OTHDPOVS(V) ;EP write out other discharge povs
+1 NEW X,C
+2 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+4 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+5 SET C=C+1
+6 QUIT
End DoDot:1
+7 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+8 WRITE !!?2,"Other Discharge POVs for this visit:",$SELECT(C=0:" None",1:"")
+9 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+11 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+12 SET C=C+1
+13 SET I=$PIECE(^AUPNVPOV(X,0),U)
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+14 SET N=$$VAL^XBDIQ1(9000010.07,X,.04)
SET N=$$UP^XLFSTR(N)
+15 WRITE !?4,I,?11,N
End DoDot:1
+16 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:80)-$LENGTH(X)\2)_X
+2 ;
WPCI ;EP write out
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,"PCI: "
+3 WRITE ?4,BGPPCI
+4 ;only display note if found procedure
IF BGPPCI=""
QUIT
+5 IF $Y>(BGPIOSL-5)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+6 WRITE !,"NOTE: For this to be used to exclude patients from the denominator, it must "
+7 WRITE !,"be described as non-primary by a physician/APN/PA. For this to be used to "
+8 WRITE !,"include patients in the numerator, the PCI must be performed within 90 "
+9 WRITE !,"minutes of hospital arrival. The patient's chart must be reviewed to make"
+10 WRITE !,"these determinations.",!
+11 QUIT
+12 ;
WFIB ;EP - write out fib meds
+1 SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 SET X=0
FOR
SET X=$ORDER(BGPUD(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPUD(X,Y))
IF Y'=+Y
QUIT
SET C=C+1
+3 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+4 WRITE !!?2,"Fibronolytic Therapy Rx Status? "
+5 IF $DATA(BGPDATA)
WRITE !?4,"Outpatient Rx: "
Begin DoDot:1
+6 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX!(BGPQUIT)
QUIT
Begin DoDot:2
+7 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=BGPDATA(BGPXX)
SET BGPLETP("TXT")=""
SET BGPLEC=0
+8 DO GETTXT^BGP1CPU4
+9 SET BGPZZ=0
FOR
SET BGPZZ=$ORDER(BGPLETXT(BGPZZ))
IF BGPZZ'=+BGPZZ!(BGPQUIT)
QUIT
Begin DoDot:3
+10 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
WRITE !?4,BGPLETXT(BGPZZ)
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
+12 IF $DATA(BGPUD)
WRITE !?4,"IV/Unit Dose: "
WRITE BGPUD
Begin DoDot:1
+13 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPUD(BGPXX))
IF BGPXX'=+BGPXX!(BGPQUIT)
QUIT
Begin DoDot:2
+14 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=BGPUD(BGPXX)
SET BGPLETP("TXT")=""
SET BGPLEC=0
+15 DO GETTXT^BGP1CPU4
+16 SET BGPZZ=0
FOR
SET BGPZZ=$ORDER(BGPLETXT(BGPZZ))
IF BGPZZ'=+BGPZZ!(BGPQUIT)
QUIT
Begin DoDot:3
+17 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
WRITE !?4,BGPLETXT(BGPZZ)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;S X=0 F S X=$O(BGPUD(X)) Q:X'=+X W !?4,BGPUD(X)
+19 IF BGPTAPRO]""
WRITE !?4,"Procedure: ",BGPTAPRO
+20 ;no data so no note
IF '$DATA(BGPDATA)
IF '$DATA(BGPUD)
IF BGPTAPRO=""
QUIT
+21 IF $Y>(BGPIOSL-4)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+22 WRITE !,"NOTE: In order to be included in the numerator, the therapy must have been"
+23 WRITE !,"received within 30 minutes or less from hospital arrival. The patient's"
+24 WRITE !,"chart must be reviewed to make this determination.",!
+25 QUIT
WLBBB ;EP - write out lbbb on ecg
+1 IF $Y>(BGPIOSL-6)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,"LBBB on ECG: "
+3 WRITE !?4,BGPLBDX
+4 SET X=0
FOR
SET X=$ORDER(BGPLBPC(X))
IF X'=+X
QUIT
WRITE !?4,BGPLBPC(X)
+5 ;no note if no data
IF BGPLBDX=""
IF '$DATA(BGPLBPC)
QUIT
+6 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if other"
+7 WRITE !,"ST-Segment Elevations or LBBB on ECGs are noted and which was performed"
+8 WRITE !,"closest to hospital arrival."
+9 QUIT
WST ;EP write out st segment elevation
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,"ST-Segment Elevation: "
+3 WRITE ?4,BGPST1
+4 IF BGPST1=""
QUIT
+5 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+6 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if other"
+7 WRITE !,"ST-Segment Elevations or LBBB on ECGs are noted and which was performed"
+8 WRITE !,"closest to hospital arrival."
+9 QUIT
WCS ;EP -write out circulatory shock
+1 IF $Y>(BGPIOSL-6)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,$SELECT(BGPPEX["B":"*",1:""),"Circulatory Shock? "
+3 IF '$DATA(BGPDATA)
WRITE " No, Not recorded"
QUIT
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+5 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
+6 WRITE !,"should be excluded if circulatory shock occurred on on arrival or within 24"
+7 WRITE !,"hours after arrival."
+8 QUIT
WHF ;EP - write out HF diagnosis
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,$SELECT(BGPPEX["A":"*",1:""),"Heart Failure? "
+3 IF '$DATA(BGPDATA)
WRITE " No, Not recorded"
QUIT
+4 ;S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
+5 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+6 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+7 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+8 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+9 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
+10 WRITE !,"should be excluded if heart failure occurred on on arrival or within 24 "
+11 WRITE !,"hours after arrival."
+12 QUIT
W23RD ;EP write out 2/3 degree
+1 IF $Y>(BGPIOSL-5)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,"2nd/3rd Degree heart Block? "
+3 IF '$DATA(BGP23RD)
WRITE " No, Not recorded"
+4 IF $DATA(BGP23RD)
IF 'BGPPACE
WRITE " Yes. "
+5 ;D
IF $DATA(BGP23RD)
IF BGPPACE
WRITE " Yes, but pacemaker present "
+6 ;.S X=0 F S X=$O(BGP23RD(X)) Q:X'=+X W !?4,BGP23RD(X)
+7 IF $DATA(BGP23RD)
SET X=0
FOR
SET X=$ORDER(BGP23RD(X))
IF X'=+X
QUIT
WRITE !?4,BGP23RD(X)
+8 IF '$DATA(BGP23RD)
QUIT
+9 IF $Y>(BGPIOSL-6)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+10 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
+11 WRITE !,"should be excluded if the patient has a 2nd/3rd degree heart block "
+12 WRITE !,"on ECG during stay AND does not have a pacemaker (also see Pacemaker"
+13 WRITE !,"below)."
PACE ;
+1 WRITE !!?2,"Pacemaker? ",$SELECT($PIECE(BGPPACE,U,2)]"":$PIECE(BGPPACE,U,2),1:"No, Not recorded")
+2 QUIT
+3 ;
WBRADY6 ;EP write out bradycardia data
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,$SELECT(BGPPEX[9:"*",1:""),"Bradycardia? "
+3 IF '$DATA(BGPBRADY)
WRITE " No, Not recorded"
QUIT
+4 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPBRADY(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+5 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+6 WRITE !?4,BGPBRADY(BGPXX)
End DoDot:1
+7 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+8 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if the patient"
+9 WRITE !,"should be excluded if bradycardia occurred on arrival or within"
+10 WRITE !,"24 hours after arrival AND if patient was not on a beta blocker at"
+11 WRITE !,"the time of bradycardia (also see Beta Blocker Rx Status below)."
+12 QUIT
WBRADY5 ;EP write out bradycardia data
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+2 WRITE !!?2,$SELECT(BGPPEX[9:"*",1:""),"Bradycardia? "
+3 IF '$DATA(BGPBRADY)
WRITE " No, Not recorded"
QUIT
+4 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPBRADY(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+5 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+6 WRITE !?4,BGPBRADY(BGPXX)
End DoDot:1
+7 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+8 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if the"
+9 WRITE !,"patient should be excluded if bradycardia occurred on day of discharge"
+10 WRITE !,"or day prior to discharge AND if patient was not on a beta blocker at"
+11 WRITE !,"the time of bradycardia (also see Beta Blocker Rx Status below)."
+12 QUIT
WPRINPRO ;EP
+1 KILL BGPXX
+2 SET BGPC=""
+3 SET BGPB=(9999999-$$DSCH^BGP1CU(BGPVINP))-1
SET BGPE=9999999-$PIECE($PIECE(^AUPNVSIT(BGPVSIT,0),U),".")
+4 FOR
SET BGPB=$ORDER(^AUPNVPRC("AA",DFN,BGPB))
IF BGPB'=+BGPB!(BGPB>BGPE)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AA",DFN,BGPB,X))
IF X'=+X
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+7 IF $PIECE(^AUPNVPRC(X,0),U,7)'="Y"
QUIT
+8 SET BGPC=$$VAL^XBDIQ1(9000010.08,X,.01)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+9 IF $Y>(BGPIOSL-3)
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+10 WRITE !?2,"Principle Procedure: ",BGPC
+11 QUIT
WOTHPROS ;EP
+1 KILL BGPXX
+2 SET BGPC=0
+3 SET BGPB=(9999999-$$DSCH^BGP1CU(BGPVINP))-1
SET BGPE=9999999-$PIECE($PIECE(^AUPNVSIT(BGPVSIT,0),U),".")
+4 FOR
SET BGPB=$ORDER(^AUPNVPRC("AA",DFN,BGPB))
IF BGPB'=+BGPB!(BGPB>BGPE)
QUIT
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AA",DFN,BGPB,X))
IF X'=+X
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+7 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF "IH"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+10 IF $PIECE(^AUPNVPRC(X,0),U,7)="Y"
QUIT
+11 SET BGPC=BGPC+1
SET BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.08,X,.01)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+12 ;go through visits in a date range for this patient, check cpts
+13 NEW D,BD,ED,Y,D,V
+14 SET BGPB=9999999-$$DSCH^BGP1CU(BGPVINP)
SET BGPE=9999999-$PIECE($PIECE(^AUPNVSIT(BGPVSIT,0),U),".")
+15 FOR
SET BGPB=$ORDER(^AUPNVSIT("AA",DFN,BGPB))
IF BGPB=""!($PIECE(BGPB,".")>BGPE)
QUIT
Begin DoDot:1
+16 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",DFN,BGPB,V))
IF V'=+V
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+18 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+19 IF "IH"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+20 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+21 SET BGPC=BGPC+1
SET BGPXX(BGPC)=$$VAL^XBDIQ1(9000010.18,X,.01)_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(X,0),U),(9999999-BGPB)),U,3)
+22 QUIT
End DoDot:3
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 SET (C,X)=0
FOR
SET X=$ORDER(BGPXX(X))
IF X'=+X
QUIT
SET C=C+1
+26 IF $Y>(BGPIOSL-(C+3))
DO HDR^BGP1CP
IF BGPQUIT
QUIT
DO L1H^BGP1CP
+27 WRITE !?2,"Other Procedures for this Visit:"
+28 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPXX(BGPX))
IF BGPX'=+BGPX
QUIT
WRITE !?4,BGPXX(BGPX)
+29 QUIT
+30 ;
