BGP2CPU ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 02 Jul 2010 9:11 AM ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
WDOB(P) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Date of Birth: ",$$DATE^BGP2UTL($P(^DPT(P,0),U,3))
Q
;
WRACE(P) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Race: ",$$VAL^XBDIQ1(2,DFN,.06)
Q
;
WZIP(P) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Postal Code: ",$$VAL^XBDIQ1(2,P,.116)
Q
WADM(I) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Admission Type: ",$$VAL^XBDIQ1(9000010.02,I,.07)
Q
WADM92(I) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Admission Type-UB92: ",$$VAL^XBDIQ1(9000010.02,I,6101)
Q
;
WADMS92(I) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Admission Source-UB92: ",$$VAL^XBDIQ1(9000010.02,I,6102)
Q
;
WDSGS92(I) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
NEW T
W !?2,"Discharge Status-UB92: " S T=$$VALI^XBDIQ1(9000010.02,I,6103) I T W $$VAL^XBDIQ1(99999.04,T,.02)
Q
;
WINS(V,P) ;EP
;check medicare
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?2,"Insurance Status: "
NEW I,D,MCR,MCD,PI,RR,J,Y,X,Q,N,C
S (MCR,MCD,PI,RR)=0
S D=$P($P(^AUPNVSIT(V,0),U),".")
S I=0
F S I=$O(^AUPNMCR(P,11,I)) Q:I'=+I!(BGPQUIT) D
. Q:$P(^AUPNMCR(P,11,I,0),U)>D
. I $P(^AUPNMCR(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
. I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
. W !?3,"Medicare Coverage Type: ",$P(^AUPNMCR(P,11,I,0),U,3)," Policy #: ",$P(^AUPNMCR(P,0),U,3)," Effective Date: ",$$DATE^BGP2UTL($P(^AUPNMCR(P,11,I,0),U))
. S MCR=1
. Q
;medicaid
Q:BGPQUIT
S Y=0
S I=0 F S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I!(BGPQUIT) D
.Q:'$D(^AUPNMCD(I,11))
.S J=0 F S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J!(BGPQUIT) D
..Q:J>D
..I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
..S MCD=1
..I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
..W !?3,"Medicaid ",$$VAL^XBDIQ1(9000004,I,.11)," Coverage Type: ",$P(^AUPNMCD(I,11,J,0),U,3)," Policy #: ",$P(^AUPNMCD(I,0),U,3),!?10," Effective Date: ",$$DATE^BGP2UTL($P(^AUPNMCD(I,11,J,0),U))
..Q
.Q
;pi
Q:BGPQUIT
S I=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I!(BGPQUIT) D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. Q:$P(^AUTNINS(X,0),U)["AHCCCS"
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S PI=1
. W !?3,"Private ",$P(^AUTNINS(X,0),U)
. S Q=$P(^AUPNPRVT(P,11,I,0),U,8)
. I Q S N=$P($G(^AUPN3PPH(Q,0)),U,4)
. I 'Q S N=$P(^AUPNPRVT(P,11,I,0),U,2)
. I Q S C=$$VAL^XBDIQ1(9000003.1,Q,.05)
. I 'Q S C=$P(^AUPNPRVT(P,11,I,0),U,3) I C S C=$P($G(^AUTTPIC(C,0)),U)
. W " Coverage Type: ",C,!?10," Policy #: ",N," Effective Date: ",$$DATE^BGP2UTL($P(^AUPNPRVT(P,11,I,0),U,6))
;RR
Q:BGPQUIT
S I=0
F S I=$O(^AUPNRRE(P,11,I)) Q:I'=+I!(BGPQUIT) D
. Q:$P(^AUPNRRE(P,11,I,0),U)>D
. I $P(^AUPNRRE(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
. I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
. W !?3,"Railroad Coverage Type: ",$P(^AUPNRRE(P,11,I,0),U,3)," Policy #: ",$P(^AUPNRRE(P,0),U,4)," Effective Date: ",$$DATE^BGP2UTL($P(^AUPNRRE(P,11,I,0),U))
. S MCR=1
. Q
I '(MCR+MCD+PI+RR) W "No Insurance per Patient Registration"
W !
Q
WBETAAL ;EP - write out BETA allergy
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[8:"*",1:""),"Beta Blocker Allergy? "
I X="" W "No, None Recorded" Q
W !?4,X
Q
;
WLASTBB ;EP write out beta blocker status
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Beta Blocker Rx Status? "
I '$D(X) W "No Rxs documented"
K BGPLETXT S BGPLETP("ICL")=0,BGPLETP("LGTH")=70,BGPLETP("NRQ")=X,BGPLETP("TXT")="",BGPLEC=0
D GETTXT^BGP2CPU4
S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
.D:$Y>(BGPIOSL-3) HDR^BGP2CP Q:BGPQUIT W !?4,BGPLETXT(BGPZZ)
;W !?4,X
I Z]"" W !?4,Z
;W !
Q
WNMIBETA ;EP - write out nmi BETA BLOCKER
I '$D(BGPDATA) D Q
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !!?2,"NMI Refusal? No"
I $Y>(BGPIOSL-6) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"NMI Refusal: Yes"
S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX D
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !?4,BGPDATA(BGPXX)
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
I Z]"" W !?4,Z
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
WCESSMED ;EP write out CESSATION DATA
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+3)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Smoking Cessation Medication Rx Status? "
I '$D(BGPDATA) W "No Rxs documented" Q
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,$$DATE^BGP2UTL($P(BGPDATA(X),U))," ",$P(BGPDATA(X),U,2)
W !,"NOTE: Per the CMS Data Abstraction Guidelines, a prescription of a smoking "
W !,"cessation aid during hospital stay or at discharge meets the numerator "
W !,"requirements."
Q
WCESS ;EP write out CESSATION DATA
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+2)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Smoking Cessation Advice/Counseling: "
I '$D(BGPDATA) W "Nothing recorded"
S BGPXX=0 F S BGPXX=$O(BGPDATA(BGPXX)) Q:BGPXX'=+BGPXX W !?4,$$DATE^BGP2UTL($P(BGPDATA(BGPXX),U))," ",$P(BGPDATA(BGPXX),U,2)
;W !
Q
WSMOKER ;EP write out smoking data
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+2)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Smoking Data: "
I '$D(BGPDATA) W "Nothing recorded"
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
;W !
Q
WAORTIC ;EP write out DX
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+2)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[7:"*",1:""),"Moderate or Severe Aortic Stenosis? "
I '$D(BGPDATA) W "No Recorded Dxs"
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
;W !
Q
WLASTACE ;EP - write out ace/arb
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"ACEI or ARB Rx Status? "
I X="",Z="" W "No Rxs" Q
W !?4,X
W !?4,Z
;W !
Q
WNMIACE(X) ;EP - write out nmi ACE/ARB
I '$D(X) D Q
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !!?2,"NMI Refusal? No"
I $Y>(BGPIOSL-6) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"NMI Refusal: Yes"
NEW Y S Y=0 F S Y=$O(X(Y)) Q:Y'=+Y W !?4,X(Y)
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
WACEALEG ;EP - write out asa allergy
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[6:"*",1:""),"ACEI and/or ARB Allergy? "
I X="",Z="" W "No, None Recorded" Q
I X]"" W !?4,"ACEI: Yes ",$P(X,U,2)
I Z]"" W !?4,"ARB: Yes ",$P(Z,U,2)
Q
WDXS ;EP write out DX
NEW X,C S (X,C)=0 F S X=$O(BGPDX(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+4)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Angioedema, Hyperkalemia, Hypotension, Renal Artery Stenosis, or Worsening"
W !,"Renal Function/Renal Disease/Dysfunction? "
I '$D(BGPDX) W !?4,"None Recorded" Q
S X=0 F S X=$O(BGPDX(X)) Q:X'=+X W !?4,BGPDX(X)
W !,"NOTE: The patient's chart needs to be reviewed to determine if this"
W !,"was documented by a physician/APN/PA before it is used to exclude "
W !,"patients from the denominator."
;W !
Q
;
WLVSD ;EP write out lsvd/cef
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+5)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"LVSD and/or EF: " I '$D(BGPDATA) W "None Recorded" Q
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
W !,"NOTE: The patient's chart still needs to be reviewed to determine if the"
W !,"LVEF is <40% or the LVS narrative indicates moderate or severe systolic"
W !,"dysfunction. Refer to CMS Specification Manual for National Hospital"
W !,"Quality Measures, Appendix H, Table 1.5 (LVSD Notes Table) for information"
W !,"on determining if patient meets CMS LVSD criteria."
Q
;
WIVUD ;EP - write out all allergies from problem list
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-5) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"ALL Unit Dose/IV Meds during Hospital Stay: ",$$DATE^BGP2UTL($P($P(^AUPNVSIT(BGPVSIT,0),U),"."))," - ",$$DATE^BGP2UTL($P($P(^AUPNVINP(BGPVINP,0),U),"."))
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^BGP2CPU4
.S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
..D:$Y>(BGPIOSL-3) HDR^BGP2CP Q:BGPQUIT W !?4,BGPLETXT(BGPZZ)
;.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
;.W !?4,BGPDATA(BGPXX)
;W !
Q
;
WWARRX ;EP - write out all warfarin rxs
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+2)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[4:"*",1:""),"Warfarin/Coumadin Contraindication?: "
I '$D(BGPDATA) W "No, None Recorded" Q
W "Yes" S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
Q
;
WASAALEG ;EP - write out asa allergy
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[3:"*",1:""),"Aspirin Allergy? "
I X="" W "No, None Recorded" Q
W !?4,"Yes ",X
Q
WALLALG ;EP - write out all allergies from problem list
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-5) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"ALL Allergies from Problem List: "
;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!(BGPQUIT) D
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !?4,BGPDATA(BGPXX)
Q
;
WALLALGT ;EP - write out all allergies from allergy tracking
NEW X,C S (X,C)=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-5) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"ALL Allergies from Allergy Tracking: "
;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!(BGPQUIT) D
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !?4,BGPDATA(BGPXX)
Q
;
WLASTAP ;EP - write out last rx
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Other Anti-Platelet Rx Status? "
;I X="" W ""
I X]"" W !?4,X
I $D(BGPUD) W !?4,"UNIT DOSE/IV During Hospital Stay: " 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^BGP2CPU4
..S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
...D:$Y>(BGPIOSL-3) HDR^BGP2CP Q:BGPQUIT W !?6,BGPLETXT(BGPZZ)
;W !
Q
WLASTASP ;EP - write out last rx
I $Y>(BGPIOSL-5) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Aspirin Rx Status? "
;I X="" W ""
I X]"" W !?4,X
I $D(BGPUD) W !?4,"UNIT DOSE/IV During Hospital Stay: " 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^BGP2CPU4
..S BGPZZ=0 F S BGPZZ=$O(BGPLETXT(BGPZZ)) Q:BGPZZ'=+BGPZZ!(BGPQUIT) D
...D:$Y>(BGPIOSL-3) HDR^BGP2CP Q:BGPQUIT W !?6,BGPLETXT(BGPZZ)
;.S BGPXX=0 F S BGPXX=$O(BGPUD(BGPXX)) Q:BGPXX'=+BGPXX D
;..I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
;..W !?6,BGPUD(BGPXX)
;S Y=0 F S Y=$O(BGPUD(Y)) Q:Y'=+Y W !?6,BGPUD(Y)
Q
WASPCPT(X) ;EP
I $G(X)="" Q
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !?4,"CPT: ",X
Q
WNMIASP ;EP - write out nmi aspirin
I '$D(BGPDATA) D Q
.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !!?2,"NMI Refusal? No"
I $Y>(BGPIOSL-6) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
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>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
..W !?6,BGPDATA(BGPXX)
;W !?4,BGPDATA(Y)
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
WCOMFORT(X) ;EP - write out comfort message
I X="" D Q
.I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
.W !!?2,"Comfort Measures? None Recorded."
I $Y>(BGPIOSL-5) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
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^BGP2CP Q:BGPQUIT D L1H^BGP2CP
I $$DOD^AUPNPAT(V)]"" D
.W !!?2,$S(BGPPEX[1!(BGPPEX[5):"*",1:""),"Date of Death: ",$$DATE^BGP2UTL($$DOD^AUPNPAT(V))
Q
;
WDT(V) ;EP - write discharge type at column 3
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W:'$D(BGPNOBA) ! W !?2,$S(BGPPEX[1!(BGPPEX[5):"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
Q
;
WTT(V) ;EP - write transferred to
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W:'$D(BGPNOBA) ! W !?2,"Transferred to: ",$$VAL^XBDIQ1(9000010.02,V,.09)
Q
;
WPPDPOV(V) ;EP
I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
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+3)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W:'$D(BGPNOBA) ! 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
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
BGP2CPU ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 02 Jul 2010 9:11 AM ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
WDOB(P) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Date of Birth: ",$$DATE^BGP2UTL($PIECE(^DPT(P,0),U,3))
+3 QUIT
+4 ;
WRACE(P) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Race: ",$$VAL^XBDIQ1(2,DFN,.06)
+3 QUIT
+4 ;
WZIP(P) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Postal Code: ",$$VAL^XBDIQ1(2,P,.116)
+3 QUIT
WADM(I) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Admission Type: ",$$VAL^XBDIQ1(9000010.02,I,.07)
+3 QUIT
WADM92(I) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Admission Type-UB92: ",$$VAL^XBDIQ1(9000010.02,I,6101)
+3 QUIT
+4 ;
WADMS92(I) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Admission Source-UB92: ",$$VAL^XBDIQ1(9000010.02,I,6102)
+3 QUIT
+4 ;
WDSGS92(I) ;EP
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 NEW T
+3 WRITE !?2,"Discharge Status-UB92: "
SET T=$$VALI^XBDIQ1(9000010.02,I,6103)
IF T
WRITE $$VAL^XBDIQ1(99999.04,T,.02)
+4 QUIT
+5 ;
WINS(V,P) ;EP
+1 ;check medicare
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !?2,"Insurance Status: "
+4 NEW I,D,MCR,MCD,PI,RR,J,Y,X,Q,N,C
+5 SET (MCR,MCD,PI,RR)=0
+6 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+7 SET I=0
+8 FOR
SET I=$ORDER(^AUPNMCR(P,11,I))
IF I'=+I!(BGPQUIT)
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNMCR(P,11,I,0),U)>D
QUIT
+10 IF $PIECE(^AUPNMCR(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+11 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+12 WRITE !?3,"Medicare Coverage Type: ",$PIECE(^AUPNMCR(P,11,I,0),U,3)," Policy #: ",$PIECE(^AUPNMCR(P,0),U,3)," Effective Date: ",$$DATE^BGP2UTL($PIECE(^AUPNMCR(P,11,I,0),U))
+13 SET MCR=1
+14 QUIT
End DoDot:1
+15 ;medicaid
+16 IF BGPQUIT
QUIT
+17 SET Y=0
+18 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I!(BGPQUIT)
QUIT
Begin DoDot:1
+19 IF '$DATA(^AUPNMCD(I,11))
QUIT
+20 SET J=0
FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J!(BGPQUIT)
QUIT
Begin DoDot:2
+21 IF J>D
QUIT
+22 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+23 SET MCD=1
+24 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+25 WRITE !?3,"Medicaid ",$$VAL^XBDIQ1(9000004,I,.11)," Coverage Type: ",$PIECE(^AUPNMCD(I,11,J,0),U,3)," Policy #: ",$PIECE(^AUPNMCD(I,0),U,3),!?10," Effective Date: ",$$DATE^BGP2UTL($PIECE(^AUPNMCD(I,11,J,0),U))
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 ;pi
+29 IF BGPQUIT
QUIT
+30 SET I=0
+31 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I!(BGPQUIT)
QUIT
Begin DoDot:1
+32 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+33 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+34 IF $PIECE(^AUTNINS(X,0),U)["AHCCCS"
QUIT
+35 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+36 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+37 SET PI=1
+38 WRITE !?3,"Private ",$PIECE(^AUTNINS(X,0),U)
+39 SET Q=$PIECE(^AUPNPRVT(P,11,I,0),U,8)
+40 IF Q
SET N=$PIECE($GET(^AUPN3PPH(Q,0)),U,4)
+41 IF 'Q
SET N=$PIECE(^AUPNPRVT(P,11,I,0),U,2)
+42 IF Q
SET C=$$VAL^XBDIQ1(9000003.1,Q,.05)
+43 IF 'Q
SET C=$PIECE(^AUPNPRVT(P,11,I,0),U,3)
IF C
SET C=$PIECE($GET(^AUTTPIC(C,0)),U)
+44 WRITE " Coverage Type: ",C,!?10," Policy #: ",N," Effective Date: ",$$DATE^BGP2UTL($PIECE(^AUPNPRVT(P,11,I,0),U,6))
End DoDot:1
+45 ;RR
+46 IF BGPQUIT
QUIT
+47 SET I=0
+48 FOR
SET I=$ORDER(^AUPNRRE(P,11,I))
IF I'=+I!(BGPQUIT)
QUIT
Begin DoDot:1
+49 IF $PIECE(^AUPNRRE(P,11,I,0),U)>D
QUIT
+50 IF $PIECE(^AUPNRRE(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+51 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+52 WRITE !?3,"Railroad Coverage Type: ",$PIECE(^AUPNRRE(P,11,I,0),U,3)," Policy #: ",$PIECE(^AUPNRRE(P,0),U,4)," Effective Date: ",$$DATE^BGP2UTL($PIECE(^AUPNRRE(P,11,I,0),U))
+53 SET MCR=1
+54 QUIT
End DoDot:1
+55 IF '(MCR+MCD+PI+RR)
WRITE "No Insurance per Patient Registration"
+56 WRITE !
+57 QUIT
WBETAAL ;EP - write out BETA allergy
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[8:"*",1:""),"Beta Blocker Allergy? "
+3 IF X=""
WRITE "No, None Recorded"
QUIT
+4 WRITE !?4,X
+5 QUIT
+6 ;
WLASTBB ;EP write out beta blocker status
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Beta Blocker Rx Status? "
+3 IF '$DATA(X)
WRITE "No Rxs documented"
+4 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=X
SET BGPLETP("TXT")=""
SET BGPLEC=0
+5 DO GETTXT^BGP2CPU4
+6 SET BGPZZ=0
FOR
SET BGPZZ=$ORDER(BGPLETXT(BGPZZ))
IF BGPZZ'=+BGPZZ!(BGPQUIT)
QUIT
Begin DoDot:1
+7 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
WRITE !?4,BGPLETXT(BGPZZ)
End DoDot:1
+8 ;W !?4,X
+9 IF Z]""
WRITE !?4,Z
+10 ;W !
+11 QUIT
WNMIBETA ;EP - write out nmi BETA BLOCKER
+1 IF '$DATA(BGPDATA)
Begin DoDot:1
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"NMI Refusal? No"
End DoDot:1
QUIT
+4 IF $Y>(BGPIOSL-6)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+5 WRITE !!?2,"NMI Refusal: Yes"
+6 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:1
+7 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+8 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+9 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+10 IF Z]""
WRITE !?4,Z
+11 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if this was"
+12 WRITE !,"documented by a physician/APN/PA before it is used to exclude patients"
+13 WRITE !,"from the denominator."
+14 QUIT
WCESSMED ;EP write out CESSATION DATA
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+3))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Smoking Cessation Medication Rx Status? "
+4 IF '$DATA(BGPDATA)
WRITE "No Rxs documented"
QUIT
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,$$DATE^BGP2UTL($PIECE(BGPDATA(X),U))," ",$PIECE(BGPDATA(X),U,2)
+6 WRITE !,"NOTE: Per the CMS Data Abstraction Guidelines, a prescription of a smoking "
+7 WRITE !,"cessation aid during hospital stay or at discharge meets the numerator "
+8 WRITE !,"requirements."
+9 QUIT
WCESS ;EP write out CESSATION DATA
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Smoking Cessation Advice/Counseling: "
+4 IF '$DATA(BGPDATA)
WRITE "Nothing recorded"
+5 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
WRITE !?4,$$DATE^BGP2UTL($PIECE(BGPDATA(BGPXX),U))," ",$PIECE(BGPDATA(BGPXX),U,2)
+6 ;W !
+7 QUIT
WSMOKER ;EP write out smoking data
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Smoking Data: "
+4 IF '$DATA(BGPDATA)
WRITE "Nothing recorded"
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+6 ;W !
+7 QUIT
WAORTIC ;EP write out DX
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,$SELECT(BGPPEX[7:"*",1:""),"Moderate or Severe Aortic Stenosis? "
+4 IF '$DATA(BGPDATA)
WRITE "No Recorded Dxs"
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+6 ;W !
+7 QUIT
WLASTACE ;EP - write out ace/arb
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"ACEI or ARB Rx Status? "
+3 IF X=""
IF Z=""
WRITE "No Rxs"
QUIT
+4 WRITE !?4,X
+5 WRITE !?4,Z
+6 ;W !
+7 QUIT
WNMIACE(X) ;EP - write out nmi ACE/ARB
+1 IF '$DATA(X)
Begin DoDot:1
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"NMI Refusal? No"
End DoDot:1
QUIT
+4 IF $Y>(BGPIOSL-6)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+5 WRITE !!?2,"NMI Refusal: Yes"
+6 NEW Y
SET Y=0
FOR
SET Y=$ORDER(X(Y))
IF Y'=+Y
QUIT
WRITE !?4,X(Y)
+7 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if this was"
+8 WRITE !,"documented by a physician/APN/PA before it is used to exclude patients"
+9 WRITE !,"from the denominator."
+10 QUIT
WACEALEG ;EP - write out asa allergy
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[6:"*",1:""),"ACEI and/or ARB Allergy? "
+3 IF X=""
IF Z=""
WRITE "No, None Recorded"
QUIT
+4 IF X]""
WRITE !?4,"ACEI: Yes ",$PIECE(X,U,2)
+5 IF Z]""
WRITE !?4,"ARB: Yes ",$PIECE(Z,U,2)
+6 QUIT
WDXS ;EP write out DX
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDX(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+4))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Angioedema, Hyperkalemia, Hypotension, Renal Artery Stenosis, or Worsening"
+4 WRITE !,"Renal Function/Renal Disease/Dysfunction? "
+5 IF '$DATA(BGPDX)
WRITE !?4,"None Recorded"
QUIT
+6 SET X=0
FOR
SET X=$ORDER(BGPDX(X))
IF X'=+X
QUIT
WRITE !?4,BGPDX(X)
+7 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if this"
+8 WRITE !,"was documented by a physician/APN/PA before it is used to exclude "
+9 WRITE !,"patients from the denominator."
+10 ;W !
+11 QUIT
+12 ;
WLVSD ;EP write out lsvd/cef
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+5))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"LVSD and/or EF: "
IF '$DATA(BGPDATA)
WRITE "None 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 still needs to be reviewed to determine if the"
+6 WRITE !,"LVEF is <40% or the LVS narrative indicates moderate or severe systolic"
+7 WRITE !,"dysfunction. Refer to CMS Specification Manual for National Hospital"
+8 WRITE !,"Quality Measures, Appendix H, Table 1.5 (LVSD Notes Table) for information"
+9 WRITE !,"on determining if patient meets CMS LVSD criteria."
+10 QUIT
+11 ;
WIVUD ;EP - write out all allergies from problem list
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-5)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"ALL Unit Dose/IV Meds during Hospital Stay: ",$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVSIT(BGPVSIT,0),U),"."))," - ",$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVINP(BGPVINP,0),U),"."))
+4 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX!(BGPQUIT)
QUIT
Begin DoDot:1
+5 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=BGPDATA(BGPXX)
SET BGPLETP("TXT")=""
SET BGPLEC=0
+6 DO GETTXT^BGP2CPU4
+7 SET BGPZZ=0
FOR
SET BGPZZ=$ORDER(BGPLETXT(BGPZZ))
IF BGPZZ'=+BGPZZ!(BGPQUIT)
QUIT
Begin DoDot:2
+8 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
WRITE !?4,BGPLETXT(BGPZZ)
End DoDot:2
End DoDot:1
+9 ;.I $Y>(BGPIOSL-3) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
+10 ;.W !?4,BGPDATA(BGPXX)
+11 ;W !
+12 QUIT
+13 ;
WWARRX ;EP - write out all warfarin rxs
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,$SELECT(BGPPEX[4:"*",1:""),"Warfarin/Coumadin Contraindication?: "
+4 IF '$DATA(BGPDATA)
WRITE "No, None Recorded"
QUIT
+5 WRITE "Yes"
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+6 QUIT
+7 ;
WASAALEG ;EP - write out asa allergy
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[3:"*",1:""),"Aspirin Allergy? "
+3 IF X=""
WRITE "No, None Recorded"
QUIT
+4 WRITE !?4,"Yes ",X
+5 QUIT
WALLALG ;EP - write out all allergies from problem list
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-5)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"ALL Allergies from Problem List: "
+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!(BGPQUIT)
QUIT
Begin DoDot:1
+6 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+7 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+8 QUIT
+9 ;
WALLALGT ;EP - write out all allergies from allergy tracking
+1 NEW X,C
SET (X,C)=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
+2 IF $Y>(BGPIOSL-5)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"ALL Allergies from Allergy Tracking: "
+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!(BGPQUIT)
QUIT
Begin DoDot:1
+6 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+7 WRITE !?4,BGPDATA(BGPXX)
End DoDot:1
+8 QUIT
+9 ;
WLASTAP ;EP - write out last rx
+1 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Other Anti-Platelet Rx Status? "
+3 ;I X="" W ""
+4 IF X]""
WRITE !?4,X
+5 IF $DATA(BGPUD)
WRITE !?4,"UNIT DOSE/IV During Hospital Stay: "
Begin DoDot:1
+6 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPUD(BGPXX))
IF BGPXX'=+BGPXX!(BGPQUIT)
QUIT
Begin DoDot:2
+7 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=BGPUD(BGPXX)
SET BGPLETP("TXT")=""
SET BGPLEC=0
+8 DO GETTXT^BGP2CPU4
+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^BGP2CP
IF BGPQUIT
QUIT
WRITE !?6,BGPLETXT(BGPZZ)
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;W !
+12 QUIT
WLASTASP ;EP - write out last rx
+1 IF $Y>(BGPIOSL-5)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Aspirin Rx Status? "
+3 ;I X="" W ""
+4 IF X]""
WRITE !?4,X
+5 IF $DATA(BGPUD)
WRITE !?4,"UNIT DOSE/IV During Hospital Stay: "
Begin DoDot:1
+6 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPUD(BGPXX))
IF BGPXX'=+BGPXX!(BGPQUIT)
QUIT
Begin DoDot:2
+7 KILL BGPLETXT
SET BGPLETP("ICL")=0
SET BGPLETP("LGTH")=70
SET BGPLETP("NRQ")=BGPUD(BGPXX)
SET BGPLETP("TXT")=""
SET BGPLEC=0
+8 DO GETTXT^BGP2CPU4
+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^BGP2CP
IF BGPQUIT
QUIT
WRITE !?6,BGPLETXT(BGPZZ)
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;.S BGPXX=0 F S BGPXX=$O(BGPUD(BGPXX)) Q:BGPXX'=+BGPXX D
+12 ;..I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
+13 ;..W !?6,BGPUD(BGPXX)
+14 ;S Y=0 F S Y=$O(BGPUD(Y)) Q:Y'=+Y W !?6,BGPUD(Y)
+15 QUIT
WASPCPT(X) ;EP
+1 IF $GET(X)=""
QUIT
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !?4,"CPT: ",X
+4 QUIT
WNMIASP ;EP - write out nmi aspirin
+1 IF '$DATA(BGPDATA)
Begin DoDot:1
+2 IF $Y>(BGPIOSL-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"NMI Refusal? No"
End DoDot:1
QUIT
+4 IF $Y>(BGPIOSL-6)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+5 WRITE !!?2,"NMI Refusal: Yes"
+6 NEW Y
SET Y=0
FOR
SET Y=$ORDER(BGPDATA(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+7 SET BGPXX=0
FOR
SET BGPXX=$ORDER(BGPDATA(BGPXX))
IF BGPXX'=+BGPXX
QUIT
Begin DoDot:2
+8 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+9 WRITE !?6,BGPDATA(BGPXX)
End DoDot:2
End DoDot:1
+10 ;W !?4,BGPDATA(Y)
+11 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if this was"
+12 WRITE !,"documented by a physician/APN/PA before it is used to exclude patients"
+13 WRITE !,"from the denominator."
+14 QUIT
WCOMFORT(X) ;EP - write out comfort message
+1 IF X=""
Begin DoDot:1
+2 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Comfort Measures? None Recorded."
End DoDot:1
QUIT
+4 IF $Y>(BGPIOSL-5)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+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^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 IF $$DOD^AUPNPAT(V)]""
Begin DoDot:1
+3 WRITE !!?2,$SELECT(BGPPEX[1!(BGPPEX[5):"*",1:""),"Date of Death: ",$$DATE^BGP2UTL($$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^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 IF '$DATA(BGPNOBA)
WRITE !
WRITE !?2,$SELECT(BGPPEX[1!(BGPPEX[5):"*",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^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+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-3)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+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+3))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+8 IF '$DATA(BGPNOBA)
WRITE !
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 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
