BGP5C3 ; IHS/CMI/LAB - calc CMS indicators 26 Sep 2004 11:28 AM ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
PNEU ;
;was there an PNEU pov on this visit
I '$$PNEUDX(BGPVSIT) Q
;
S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
S $P(BGPX,U,5)=$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
S BGPSKIP=0 K BGPZ
I $$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))<18 S BGPX="*"_BGPX,BGPSKIP=1,BGPZ(1)="under 18 yrs of age"
S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
S $P(BGPX,U,7)=Z
I $$TRANSIN(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(2)="transferred in from another hospital"
S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
S $P(BGPX,U,8)=Z
Q:$D(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT))
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX ;a hit on list 1
K BGPZ1 I $D(BGPZ) S X=0 F S X=$O(BGPZ(X)) Q:X'=+X S:$G(BGPZ1)]"" BGPZ1=BGPZ1_", " S BGPZ1=$G(BGPZ1)_BGPZ(X)
I $D(BGPZ1) S BGPZ1="Exclusions: "_BGPZ1 S $P(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
S BGPCOUNT("L1",BGPIND)=$G(BGPCOUNT("L1",BGPIND))+1
;set up second list after applying exclusions
Q:BGPSKIP
S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
S $P(BGPX,U,5)=$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
S $P(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
S $P(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
S BGPCOUNT("L2",BGPIND)=$G(BGPCOUNT("L2",BGPIND))+1
;get other povs
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
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 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)
.S C=C+1
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I,$E(^(C),9)=N
.Q
ABIRX ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?")=""
K BGPDATA
D ABRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?",X)=BGPDATA(X)
PNEUVAX ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?")=""
K BGPDATA
D PNEUVAX1(DFN,.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?",X)=BGPDATA(X)
ABGPO ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?")=""
K BGPDATA
D ABGPO1(DFN,$P($P(BGPVSIT0,U),"."),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?",X)=BGPDATA(X)
D EN^BGP5C12
Q
ABGPO1(P,BGPA,BGPY) ;
;get all O2 measurements on or after admission date
S BGPC=0
K BGPG S Y="BGPG(",X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BGPA)_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$P(^AUPNVMSR(Y,0),U,4)
.S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP5UTL($P(BGPG(X),U))_" value: "_N
.Q
;now check for cpts
S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S C=$P(^AUPNVCPT(X,0),U)
.Q:'$$ICD^ATXCHK(C,T,1)
.S D=$P(^AUPNVCPT(X,0),U,3),D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$P($$CPT^ICPTCOD(C),U,2)_" "_$P($$CPT^ICPTCOD(C),U,3)_" "_$$DATE^BGP5UTL(D)
.Q
K BGPG S Y="BGPG(",X=P_"^ALL LAB [BGP CMS ABG TESTS;DURING "_$$FMTE^XLFDT(BGPA)_"-"_$$FMTE^XLFDT(DT) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$P(^AUPNVLAB(Y,0),U,4)
.S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,Y,.01)_" "_$$DATE^BGP5UTL($P(BGPG(X),U))_" value: "_N
.Q
Q
ABRX1(P,BGPA,BGPD,BGPY) ;EP
;get last aspirin rx before date of adm
NEW BGPG,BGPC,X,Y,Z,E,BD,ED
S BGPC=0
S ED=$$FMADD^XLFDT(BGPA,-1)
S BD=$$FMADD^XLFDT(BGPA,-365)
D GETMEDS^BGP5C1(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP5C1(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
Q
SET ;
S BGPX(D)=C1_" "_C_" "_$$DATE^BGP5UTL(D)
Q
PNEUVAX1(P,BGPY) ;
K BGPG,BGPX
S BGPC=0
S X=P_"^ALL IMM 33" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S X=P_"^ALL IMM 100" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S X=P_"^ALL IMM 109" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S %=P_"^ALL PROCEDURE 99.55",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPRC(Y,0))
.S Y=$P(^AUPNVPRC(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDOP^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDOP^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V03.82",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V03.89",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V06.6",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
;now check for cpts
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S C1=$$VAL^XBDIQ1(9000010.18,X,.01)
.I C1'=90732,C1'=90669 Q
.S C=$$VAL^XBDIQ1(9000010.18,X,.019)
.S D=$P(^AUPNVCPT(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.D SET
.Q
;refusals?
K BGPI F X=33,100,109 S Y=$O(^AUTTIMM("C",X,0)) I Y S BGPI(Y)=""
S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,X)) Q:X'=+X D
.Q:'$D(BGPI(X)) ;not an ACEI
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D
..Q:$D(BGPX(Y)) S BGPX(Y)="REFUSAL: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP5UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
S (X,G)=0,Y=$O(^AUTTIMM("C",33,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",100,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",109,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
S D=0 F S D=$O(BGPX(D)) Q:D'=+D S BGPC=BGPC+1,BGPY(BGPC)=BGPX(D)
K BGPX,BGPC,BGPI,X,Y,D
Q
AMA(H) ;
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=3 Q 1
Q 0
PNEUDX(V) ;
S C=$$PRIMPOV^APCLV(V,"I")
I C="" Q 0 ;no primary dx
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
I $$ICD^ATXCHK(C,T,9) Q 1 ;primary dx of pneumonia
;PRIMARY of resp failure and seconday of pneumonia
S T=$O(^ATXAX("B","BGP CMS SEPTI/RESP FAIL DXS",0))
I '$$ICD^ATXCHK(C,T,9) Q 0 ;resp failure not primary pov
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
S (X,G)=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNVPOV(X,0))
.Q:$P(^AUPNVPOV(X,0),U,12)="P"
.S I=$P(^AUPNVPOV(X,0),U)
.Q:'$$ICD^ATXCHK(I,T,9)
.S G=1
.Q
Q G
EXPIRED(H) ;
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=4!(X=5)!(X=6)!(X=7) Q 1
Q 0
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
TRANSIN(H) ;
S X=$P(^AUPNVINP(H,0),U,7)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=2!(X=3) Q 1
Q 0
TRANS(H) ;
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=2 Q 1
Q 0
BGP5C3 ; IHS/CMI/LAB - calc CMS indicators 26 Sep 2004 11:28 AM ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
PNEU ;
+1 ;was there an PNEU pov on this visit
+2 IF '$$PNEUDX(BGPVSIT)
QUIT
+3 ;
+4 SET BGPX=$PIECE(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$PIECE($PIECE(BGPVSIT0,U),"."))
+5 SET $PIECE(BGPX,U,5)=$$DATE^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
+6 SET $PIECE(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
+7 SET BGPSKIP=0
KILL BGPZ
+8 IF $$AGE^AUPNPAT(DFN,$PIECE($PIECE(BGPVSIT0,U),"."))<18
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(1)="under 18 yrs of age"
+9 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+10 SET $PIECE(BGPX,U,7)=Z
+11 IF $$TRANSIN(BGPVINP)
IF 'BGPSKIP
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(2)="transferred in from another hospital"
+12 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+13 SET $PIECE(BGPX,U,8)=Z
+14 IF $DATA(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT))
QUIT
+15 ;a hit on list 1
SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+16 KILL BGPZ1
IF $DATA(BGPZ)
SET X=0
FOR
SET X=$ORDER(BGPZ(X))
IF X'=+X
QUIT
IF $GET(BGPZ1)]""
SET BGPZ1=BGPZ1_", "
SET BGPZ1=$GET(BGPZ1)_BGPZ(X)
+17 IF $DATA(BGPZ1)
SET BGPZ1="Exclusions: "_BGPZ1
SET $PIECE(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
+18 SET BGPCOUNT("L1",BGPIND)=$GET(BGPCOUNT("L1",BGPIND))+1
+19 ;set up second list after applying exclusions
+20 IF BGPSKIP
QUIT
+21 SET BGPX=$PIECE(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$PIECE(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$PIECE($PIECE(BGPVSIT0,U),"."))
+22 SET $PIECE(BGPX,U,5)=$$DATE^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
+23 SET $PIECE(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
+24 SET $PIECE(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+25 SET $PIECE(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+26 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+27 SET BGPCOUNT("L2",BGPIND)=$GET(BGPCOUNT("L2",BGPIND))+1
+28 ;get other povs
+29 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
+30 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+31 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+32 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+33 SET I=$PIECE(^AUPNVPOV(X,0),U)
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+34 SET N=$$VAL^XBDIQ1(9000010.07,X,.04)
SET N=$$UP^XLFSTR(N)
+35 SET C=C+1
+36 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I
SET $EXTRACT(^(C),9)=N
+37 QUIT
End DoDot:1
ABIRX ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?")=""
+2 KILL BGPDATA
+3 DO ABRX1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?",X)=BGPDATA(X)
End DoDot:1
PNEUVAX ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?")=""
+2 KILL BGPDATA
+3 DO PNEUVAX1(DFN,.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?",X)=BGPDATA(X)
End DoDot:1
ABGPO ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?")=""
+2 KILL BGPDATA
+3 DO ABGPO1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?",X)=BGPDATA(X)
End DoDot:1
+6 DO EN^BGP5C12
+7 QUIT
ABGPO1(P,BGPA,BGPY) ;
+1 ;get all O2 measurements on or after admission date
+2 SET BGPC=0
+3 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BGPA)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(X,Y)
+4 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+5 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+6 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP5UTL($PIECE(BGPG(X),U))_" value: "_N
+7 QUIT
End DoDot:1
+8 ;now check for cpts
+9 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+12 SET C=$PIECE(^AUPNVCPT(X,0),U)
+13 IF '$$ICD^ATXCHK(C,T,1)
QUIT
+14 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+15 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_$PIECE($$CPT^ICPTCOD(C),U,2)_" "_$PIECE($$CPT^ICPTCOD(C),U,3)_" "_$$DATE^BGP5UTL(D)
+16 QUIT
End DoDot:1
+17 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL LAB [BGP CMS ABG TESTS;DURING "_$$FMTE^XLFDT(BGPA)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(X,Y)
+18 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+19 SET N=$PIECE(^AUPNVLAB(Y,0),U,4)
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,Y,.01)_" "_$$DATE^BGP5UTL($PIECE(BGPG(X),U))_" value: "_N
+21 QUIT
End DoDot:1
+22 QUIT
ABRX1(P,BGPA,BGPD,BGPY) ;EP
+1 ;get last aspirin rx before date of adm
+2 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+3 SET BGPC=0
+4 SET ED=$$FMADD^XLFDT(BGPA,-1)
+5 SET BD=$$FMADD^XLFDT(BGPA,-365)
+6 DO GETMEDS^BGP5C1(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
+7 SET BD=BGPA
+8 SET ED=$$FMADD^XLFDT(BGPD,30)
+9 DO GETMEDS^BGP5C1(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
+10 QUIT
SET ;
+1 SET BGPX(D)=C1_" "_C_" "_$$DATE^BGP5UTL(D)
+2 QUIT
PNEUVAX1(P,BGPY) ;
+1 KILL BGPG,BGPX
+2 SET BGPC=0
+3 SET X=P_"^ALL IMM 33"
SET E=$$START1^APCLDF(X,"BGPG(")
+4 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+5 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+6 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+7 IF 'Y
QUIT
+8 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+9 IF C=""
QUIT
+10 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+11 DO SET
+12 QUIT
End DoDot:1
+13 KILL BGPG
SET X=P_"^ALL IMM 100"
SET E=$$START1^APCLDF(X,"BGPG(")
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+16 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+17 IF 'Y
QUIT
+18 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+19 IF C=""
QUIT
+20 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+21 DO SET
+22 QUIT
End DoDot:1
+23 KILL BGPG
SET X=P_"^ALL IMM 109"
SET E=$$START1^APCLDF(X,"BGPG(")
+24 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+25 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+26 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+27 IF 'Y
QUIT
+28 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+29 IF C=""
QUIT
+30 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+31 DO SET
+32 QUIT
End DoDot:1
+33 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.55"
SET E=$$START1^APCLDF(%,"BGPG(")
+34 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+35 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+36 SET Y=$PIECE(^AUPNVPRC(Y,0),U,1)
+37 IF 'Y
QUIT
+38 SET D=$PIECE(BGPG(X),U)
+39 SET C=$PIECE($$ICDOP^ICDCODE(Y,D),U,4)
+40 IF C=""
QUIT
+41 SET C1=$PIECE($$ICDOP^ICDCODE(Y,D),U,2)
+42 DO SET
+43 QUIT
End DoDot:1
+44 KILL BGPG
SET %=P_"^ALL DX V03.82"
SET E=$$START1^APCLDF(%,"BGPG(")
+45 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+46 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+47 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+48 IF 'Y
QUIT
+49 SET D=$PIECE(BGPG(X),U)
+50 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+51 IF C=""
QUIT
+52 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+53 DO SET
+54 QUIT
End DoDot:1
+55 KILL BGPG
SET %=P_"^ALL DX V03.89"
SET E=$$START1^APCLDF(%,"BGPG(")
+56 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+57 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+58 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+59 IF 'Y
QUIT
+60 SET D=$PIECE(BGPG(X),U)
+61 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+62 IF C=""
QUIT
+63 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+64 DO SET
+65 QUIT
End DoDot:1
+66 KILL BGPG
SET %=P_"^ALL DX V06.6"
SET E=$$START1^APCLDF(%,"BGPG(")
+67 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+68 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+69 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+70 IF 'Y
QUIT
+71 SET D=$PIECE(BGPG(X),U)
+72 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+73 IF C=""
QUIT
+74 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+75 DO SET
+76 QUIT
End DoDot:1
+77 ;now check for cpts
+78 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+79 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+80 SET C1=$$VAL^XBDIQ1(9000010.18,X,.01)
+81 IF C1'=90732
IF C1'=90669
QUIT
+82 SET C=$$VAL^XBDIQ1(9000010.18,X,.019)
+83 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
+84 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+85 DO SET
+86 QUIT
End DoDot:1
+87 ;refusals?
+88 KILL BGPI
FOR X=33,100,109
SET Y=$ORDER(^AUTTIMM("C",X,0))
IF Y
SET BGPI(Y)=""
+89 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,X))
IF X'=+X
QUIT
Begin DoDot:1
+90 ;not an ACEI
IF '$DATA(BGPI(X))
QUIT
+91 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+92 SET Y=9999999-D
+93 IF $DATA(BGPX(Y))
QUIT
SET BGPX(Y)="REFUSAL: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP5UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
+94 QUIT
End DoDot:2
+95 QUIT
End DoDot:1
+96 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",33,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+97 SET R=$PIECE(^BIPC(X,0),U,3)
+98 IF R=""
QUIT
+99 IF '$DATA(^BICONT(R,0))
QUIT
+100 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+101 SET D=$PIECE(^BIPC(X,0),U,4)
+102 IF D=""
QUIT
+103 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
End DoDot:1
+104 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",100,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+105 SET R=$PIECE(^BIPC(X,0),U,3)
+106 IF R=""
QUIT
+107 IF '$DATA(^BICONT(R,0))
QUIT
+108 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+109 SET D=$PIECE(^BIPC(X,0),U,4)
+110 IF D=""
QUIT
+111 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
End DoDot:1
+112 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",109,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+113 SET R=$PIECE(^BIPC(X,0),U,3)
+114 IF R=""
QUIT
+115 IF '$DATA(^BICONT(R,0))
QUIT
+116 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+117 SET D=$PIECE(^BIPC(X,0),U,4)
+118 IF D=""
QUIT
+119 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP5UTL(D)
End DoDot:1
+120 SET D=0
FOR
SET D=$ORDER(BGPX(D))
IF D'=+D
QUIT
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPX(D)
+121 KILL BGPX,BGPC,BGPI,X,Y,D
+122 QUIT
AMA(H) ;
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=3
QUIT 1
+5 QUIT 0
PNEUDX(V) ;
+1 SET C=$$PRIMPOV^APCLV(V,"I")
+2 ;no primary dx
IF C=""
QUIT 0
+3 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+4 ;primary dx of pneumonia
IF $$ICD^ATXCHK(C,T,9)
QUIT 1
+5 ;PRIMARY of resp failure and seconday of pneumonia
+6 SET T=$ORDER(^ATXAX("B","BGP CMS SEPTI/RESP FAIL DXS",0))
+7 ;resp failure not primary pov
IF '$$ICD^ATXCHK(C,T,9)
QUIT 0
+8 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+9 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+11 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+12 SET I=$PIECE(^AUPNVPOV(X,0),U)
+13 IF '$$ICD^ATXCHK(I,T,9)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 QUIT G
EXPIRED(H) ;
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=4!(X=5)!(X=6)!(X=7)
QUIT 1
+5 QUIT 0
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
TRANSIN(H) ;
+1 SET X=$PIECE(^AUPNVINP(H,0),U,7)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=2!(X=3)
QUIT 1
+5 QUIT 0
TRANS(H) ;
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=2
QUIT 1
+5 QUIT 0
