- 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 ;----------
