BGP2CPU3 ; IHS/CMI/LAB - calc CMS measures ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
;
EXCL487 ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
S BGPXX=$$LASTDXI^BGP2UTL1(DFN,"487.0",$P($P(BGPVSIT0,U),"."),$$DSCH^BGP2CU(BGPVINP),"HI") I BGPXX S BGPN=$$VAL^XBDIQ1(9000010.07,$P(BGPXX,U,5),.04)
W !!?2,$S(BGPPEX["L":"*",1:""),"Influenza Dx: "_$S(BGPPEX["L":"Yes, 487.0 "_BGPN,1:"No")
Q
WFLU ;EP
S X=0,C=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+8)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Influenza IZ Status? "
I '$D(BGPDATA) Q
I $D(BGPDATA) S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
W !,"NOTE: If Influenza vaccine received prior to admission, in order to be "
W !,"included in the CMS measure, it must be determined if the patient received"
W "it during the CURRENT flu season. The CMS Data Abstraction Guidelines"
W !,"define current flu season as beginning when this season's flu vaccine "
W !,"is made available to the public, e.g. if the vaccine is available in"
W !,"September, then the flu season is September-February. However, for this "
W !,"measure, the hospitals are only responsible for discharges October-February."
;W !
Q
;
WWOUND ;EP - write transferred to
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX["J":"*",1:""),"Home Wound Care? ",$P(X,U,2)
Q
;
WNURSHOM ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX["H":"*",1:""),"Nursing Home Visit? ",$P(X,U,2)
Q
;
WHOS2DAY ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX["G":"*",1:""),"Hospitalized for 2 days in past 3 months? ",$P(X,U,2)
Q
;
WPRIORHO ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX["F"!(BGPPEX["G"):"*",1:""),"Prior Hospitalization? ",$S(X]""!(Y]""):"Yes",1:"No")
W !?4,"Hospital Stay prior 14 days: ",$S(X]"":"Yes, ",1:"No "),$P(X,U,2)
W !?4,"Hospitalized at least 2 days: ",$S(Y]"":"Yes",1:"No") I Y]"" W !?6,$P(Y,U,2)," ",$P(Y,U,3)
Q
;
WEXCL1 ;EP
S X=0,C=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+4)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
S BGPAST=""
I BGPPEX["A"!(BGPPEX["B")!(BGPPEX["C")!(BGPPEX["D")!(BGPPEX["E")!(BGPPEX["K")!(BGPPEX["I") S BGPAST=1
W !!?2,$S(BGPAST:"*",1:""),"HIV Positive/AIDS, Systemic Chemotherapy/Immunosuppressive Therapy,"
W !?2,"Leukemia, Lymphoma, Radiation Therapy, or Chronic Dialysis? "
I '$D(BGPDATA) W !?4,"No, Not recorded." Q
I $D(BGPDATA) S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
;W !
Q
WOTHINF ;EP
I $Y>(BGPIOSL-7) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Other Suspected Source of Infection? "
I X W !?4,"Admitting Diagnosis: ["_$P(X,U,2)_"]"
I X="" Q
W !,"NOTE: If patient had other suspected source of infection, this criterion "
W !,"should only be used to exclude patients when the patient did not receive"
W !,"an antibiotic regimen recommended for pneumonia but did receive"
W !,"antibiotics within the first 24 hours of hospitalization."
Q
;
WPSEUDO ;EP
I $Y>(BGPIOSL-7) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Pseudomonas Risk? "
I BGPPSE]"" W !?4,$P(BGPPSE,U,2)
I BGPCOPD]"" W !?4,$P(BGPCOPD,U,2)
I BGPCOPD]"",BGPPSE="" D
.W !,"NOTE: The patient's chart needs to be reviewed to see if there is"
.W !,"physician/NP/PA documented history of repeated antibiotics or chronic "
.W !,"corticosteroid use before this patient can be considered to have risk of"
.W !,"pseudomonas."
.Q
Q
;
WERBC ;EP
S X=0,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[6:"*",1:""),"ER Visit with Blood Culture Status: "
I $D(BGPDATA) S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
W !
Q
WANTIRX ;EP
S X=0,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[8!(BGPPEX[7):"*",1:""),"Recent Antibiotic Rx Status: "
I $D(BGPDATA) S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
;W !
Q
;
WPNEUMO ;EP
S X=0,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,"Pneumovax Status? "
I $D(BGPDATA) S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X W !?4,BGPDATA(X)
W !
Q
;
WCYSTIC ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[5:"*",1:""),"Cystic Fibrosis? ",$P(X,U,2)
Q
;
WADMDX ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[3:"*",1:""),"Admitting Dx? ",$$VAL^XBDIQ1(9000010.02,BGPVINP,.12)_" "_$P($$ICDDX^ICDCODE($P(^AUPNVINP(BGPVINP,0),U,12),$$VD^APCLV(BGPVSIT)),U,4)
Q
;
WERPNEU ;EP
I $Y>(BGPIOSL-2) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,$S(BGPPEX[4:"*",1:""),"ER Visit w/ No Pneumonia DX? ",$P(X,U,2)
Q
;
WCHEST ;EP - write out chest xray data
S X=0,C=0 F S X=$O(BGPDATA(X)) Q:X'=+X S Y=0 F S Y=$O(BGPDATA(X,Y)) Q:Y'=+Y S C=C+1
S X=0 F S X=$O(BGPSCAN(X)) Q:X'=+X S Y=0 F S Y=$O(BGPSCAN(X,Y)) Q:Y'=+Y S C=C+1
I $Y>(BGPIOSL-(C+3)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"Chest X-ray/CT Scan? "
I $D(BGPDATA)!($D(BGPSCAN)) D
.S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X S Y=0 F S Y=$O(BGPDATA(X,Y)) Q:Y'=+Y W !?4,BGPDATA(X,Y)
.S X=0 F S X=$O(BGPSCAN(X)) Q:X'=+X S Y=0 F S Y=$O(BGPSCAN(X,Y)) Q:Y'=+Y W !?4,BGPSCAN(X,Y)
.W !,"NOTE: The patient's chart needs to be reviewed to determine if patient"
.W !,"should be excluded if the finding was not abnormal."
Q
;
WABGPO ;EP - write out chest xray data
S X=0,C=0 F S X=$O(BGPDATA(X)) Q:X'=+X S C=C+1
I $Y>(BGPIOSL-(C+6)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
W !!?2,"ABG/PO Status? "
I '$D(BGPDATA) Q
I $D(BGPDATA) 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"
W !,"the oxygen saturation was performed either within 24 hours prior"
W !,"to arrival or within 24 hours after hospital arrival."
;W !
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-4) 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,"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[2:"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
Q
;
WDT9(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[9:"*",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 !?2,"Transferred to: ",$$VAL^XBDIQ1(9000010.02,V,.09)
Q
;
WPNEUPOV(V) ;EP
I $Y>(BGPIOSL-4) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
S X=$$PNEUMODX^BGP2CU(V)
W:'$D(BGPNOBA) ! W !?2,"Pneumonia Discharge POV:"
W !?4,$P(X,U) I $P(X,U,2)]"" W !?4,$P(X,U,2)
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:80)-$L(X)\2)_X
WPPDPOV(V) ;EP
I $Y>(BGPIOSL-2) 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+2)) D HDR^BGP2CP Q:BGPQUIT D L1H^BGP2CP
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
BGP2CPU3 ; IHS/CMI/LAB - calc CMS measures ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
+3 ;
EXCL487 ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 SET BGPXX=$$LASTDXI^BGP2UTL1(DFN,"487.0",$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH^BGP2CU(BGPVINP),"HI")
IF BGPXX
SET BGPN=$$VAL^XBDIQ1(9000010.07,$PIECE(BGPXX,U,5),.04)
+3 WRITE !!?2,$SELECT(BGPPEX["L":"*",1:""),"Influenza Dx: "_$SELECT(BGPPEX["L":"Yes, 487.0 "_BGPN,1:"No")
+4 QUIT
WFLU ;EP
+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-(C+8))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Influenza IZ Status? "
+4 IF '$DATA(BGPDATA)
QUIT
+5 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+6 WRITE !,"NOTE: If Influenza vaccine received prior to admission, in order to be "
+7 WRITE !,"included in the CMS measure, it must be determined if the patient received"
+8 WRITE "it during the CURRENT flu season. The CMS Data Abstraction Guidelines"
+9 WRITE !,"define current flu season as beginning when this season's flu vaccine "
+10 WRITE !,"is made available to the public, e.g. if the vaccine is available in"
+11 WRITE !,"September, then the flu season is September-February. However, for this "
+12 WRITE !,"measure, the hospitals are only responsible for discharges October-February."
+13 ;W !
+14 QUIT
+15 ;
WWOUND ;EP - write transferred to
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX["J":"*",1:""),"Home Wound Care? ",$PIECE(X,U,2)
+3 QUIT
+4 ;
WNURSHOM ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX["H":"*",1:""),"Nursing Home Visit? ",$PIECE(X,U,2)
+3 QUIT
+4 ;
WHOS2DAY ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX["G":"*",1:""),"Hospitalized for 2 days in past 3 months? ",$PIECE(X,U,2)
+3 QUIT
+4 ;
WPRIORHO ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX["F"!(BGPPEX["G"):"*",1:""),"Prior Hospitalization? ",$SELECT(X]""!(Y]""):"Yes",1:"No")
+3 WRITE !?4,"Hospital Stay prior 14 days: ",$SELECT(X]"":"Yes, ",1:"No "),$PIECE(X,U,2)
+4 WRITE !?4,"Hospitalized at least 2 days: ",$SELECT(Y]"":"Yes",1:"No")
IF Y]""
WRITE !?6,$PIECE(Y,U,2)," ",$PIECE(Y,U,3)
+5 QUIT
+6 ;
WEXCL1 ;EP
+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-(C+4))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 SET BGPAST=""
+4 IF BGPPEX["A"!(BGPPEX["B")!(BGPPEX["C")!(BGPPEX["D")!(BGPPEX["E")!(BGPPEX["K")!(BGPPEX["I")
SET BGPAST=1
+5 WRITE !!?2,$SELECT(BGPAST:"*",1:""),"HIV Positive/AIDS, Systemic Chemotherapy/Immunosuppressive Therapy,"
+6 WRITE !?2,"Leukemia, Lymphoma, Radiation Therapy, or Chronic Dialysis? "
+7 IF '$DATA(BGPDATA)
WRITE !?4,"No, Not recorded."
QUIT
+8 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+9 ;W !
+10 QUIT
WOTHINF ;EP
+1 IF $Y>(BGPIOSL-7)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Other Suspected Source of Infection? "
+3 IF X
WRITE !?4,"Admitting Diagnosis: ["_$PIECE(X,U,2)_"]"
+4 IF X=""
QUIT
+5 WRITE !,"NOTE: If patient had other suspected source of infection, this criterion "
+6 WRITE !,"should only be used to exclude patients when the patient did not receive"
+7 WRITE !,"an antibiotic regimen recommended for pneumonia but did receive"
+8 WRITE !,"antibiotics within the first 24 hours of hospitalization."
+9 QUIT
+10 ;
WPSEUDO ;EP
+1 IF $Y>(BGPIOSL-7)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,"Pseudomonas Risk? "
+3 IF BGPPSE]""
WRITE !?4,$PIECE(BGPPSE,U,2)
+4 IF BGPCOPD]""
WRITE !?4,$PIECE(BGPCOPD,U,2)
+5 IF BGPCOPD]""
IF BGPPSE=""
Begin DoDot:1
+6 WRITE !,"NOTE: The patient's chart needs to be reviewed to see if there is"
+7 WRITE !,"physician/NP/PA documented history of repeated antibiotics or chronic "
+8 WRITE !,"corticosteroid use before this patient can be considered to have risk of"
+9 WRITE !,"pseudomonas."
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
WERBC ;EP
+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-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,$SELECT(BGPPEX[6:"*",1:""),"ER Visit with Blood Culture Status: "
+4 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+5 WRITE !
+6 QUIT
WANTIRX ;EP
+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-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,$SELECT(BGPPEX[8!(BGPPEX[7):"*",1:""),"Recent Antibiotic Rx Status: "
+4 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+5 ;W !
+6 QUIT
+7 ;
WPNEUMO ;EP
+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-(C+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"Pneumovax Status? "
+4 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+5 WRITE !
+6 QUIT
+7 ;
WCYSTIC ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[5:"*",1:""),"Cystic Fibrosis? ",$PIECE(X,U,2)
+3 QUIT
+4 ;
WADMDX ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[3:"*",1:""),"Admitting Dx? ",$$VAL^XBDIQ1(9000010.02,BGPVINP,.12)_" "_$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVINP(BGPVINP,0),U,12),$$VD^APCLV(BGPVSIT)),U,4)
+3 QUIT
+4 ;
WERPNEU ;EP
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !!?2,$SELECT(BGPPEX[4:"*",1:""),"ER Visit w/ No Pneumonia DX? ",$PIECE(X,U,2)
+3 QUIT
+4 ;
WCHEST ;EP - write out chest xray data
+1 SET X=0
SET C=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPDATA(X,Y))
IF Y'=+Y
QUIT
SET C=C+1
+2 SET X=0
FOR
SET X=$ORDER(BGPSCAN(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPSCAN(X,Y))
IF Y'=+Y
QUIT
SET C=C+1
+3 IF $Y>(BGPIOSL-(C+3))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+4 WRITE !!?2,"Chest X-ray/CT Scan? "
+5 IF $DATA(BGPDATA)!($DATA(BGPSCAN))
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPDATA(X,Y))
IF Y'=+Y
QUIT
WRITE !?4,BGPDATA(X,Y)
+7 SET X=0
FOR
SET X=$ORDER(BGPSCAN(X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPSCAN(X,Y))
IF Y'=+Y
QUIT
WRITE !?4,BGPSCAN(X,Y)
+8 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if patient"
+9 WRITE !,"should be excluded if the finding was not abnormal."
End DoDot:1
+10 QUIT
+11 ;
WABGPO ;EP - write out chest xray data
+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-(C+6))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+3 WRITE !!?2,"ABG/PO Status? "
+4 IF '$DATA(BGPDATA)
QUIT
+5 IF $DATA(BGPDATA)
SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
WRITE !?4,BGPDATA(X)
+6 WRITE !,"NOTE: The patient's chart needs to be reviewed to determine if"
+7 WRITE !,"the oxygen saturation was performed either within 24 hours prior"
+8 WRITE !,"to arrival or within 24 hours after hospital arrival."
+9 ;W !
+10 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-4)
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,"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[2:"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
+3 QUIT
+4 ;
WDT9(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[9:"*",1:""),"Discharge Type: ",$$VAL^XBDIQ1(9000010.02,V,.06)
+3 QUIT
WTT(V) ;EP - write transferred to
+1 IF $Y>(BGPIOSL-2)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 WRITE !?2,"Transferred to: ",$$VAL^XBDIQ1(9000010.02,V,.09)
+3 QUIT
+4 ;
WPNEUPOV(V) ;EP
+1 IF $Y>(BGPIOSL-4)
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+2 SET X=$$PNEUMODX^BGP2CU(V)
+3 IF '$DATA(BGPNOBA)
WRITE !
WRITE !?2,"Pneumonia Discharge POV:"
+4 WRITE !?4,$PIECE(X,U)
IF $PIECE(X,U,2)]""
WRITE !?4,$PIECE(X,U,2)
+5 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
WPPDPOV(V) ;EP
+1 IF $Y>(BGPIOSL-2)
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+2))
DO HDR^BGP2CP
IF BGPQUIT
QUIT
DO L1H^BGP2CP
+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
