BGP5CU ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM ;
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
CHESTXRY(P,BDATE,EDATE,BGPY) ;EP
K BGPY
I '$G(P) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW C,BD,ED,X,Y,D,G,V,I
S C=0
;go through visits in a date range for this patient, check cpts
S ED=(9999999-EDATE)-1,BD=9999999-BDATE,G=0
S T=$O(^ATXAX("B","BGP CMS CHEST XRAY CPT",0))
I 'T W BGPBOMB
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...I $$ICD^BGP5UTL2($P(^AUPNVCPT(X,0),U),T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-$P(ED,"."))),U,3)
..;now go through v rads
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X D
...S I=$P(^AUPNVRAD(X,0),U) Q:I="" S I=$P($G(^RAMIS(71,I,0)),U,9) Q:I=""
...I $$ICD^BGP5UTL2(I,T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,3)_" Impression: "_$P($G(^AUPNVRAD(X,11)),U,1)
..; now v tran
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S I=$P(^AUPNVTC(X,0),U,7)
...Q:I=""
...I $$ICD^BGP5UTL2(I,T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,3)
..;now check V PROCEDURE
..S T=$O(^ATXAX("B","BGP CMS CHEST XRAY PROC",0))
..I 'T W BGPBOMB
..S X=0 F S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X D
...I $$ICD^BGP5UTL2($P(^AUPNVPRC(X,0),U),T,0) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$ICDOP^BGP5UTL2($P(^AUPNVPRC(X,0),U),(9999999-$P(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
..;now check V POV
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
...S I=$P($G(^AUPNVPOV(X,0)),U)
...Q:'I
...I $P($$ICDDX^BGP5UTL2(I),U,2)="V72.5",$$UP^XLFSTR($$VAL^XBDIQ1(9000010.07,X,.04))["CHEST" S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$ICDDX^BGP5UTL2(I,(9999999-$P(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.07,X,.04)
...Q
..Q
.Q
Q
;
CTSCAN(P,BDATE,EDATE,BGPY) ;EP
K BGPY
I '$G(P) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW C,BD,ED,X,Y,D,G,V,I
S C=0
;go through visits in a date range for this patient, check cpts
S ED=(9999999-EDATE)-1,BD=9999999-BDATE,G=0
S T=$O(^ATXAX("B","BGP CMS CT SCAN CPT",0))
I 'T W BGPBOMB
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...I $$ICD^BGP5UTL2($P(^AUPNVCPT(X,0),U),T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD($P(^AUPNVCPT(X,0),U),(9999999-$P(ED,"."))),U,3)
..;now go through v rads
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X D
...S I=$P(^AUPNVRAD(X,0),U) Q:I="" S I=$P($G(^RAMIS(71,I,0)),U,9) Q:I=""
...I $$ICD^BGP5UTL2(I,T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,3)_" Impression: "_$P($G(^AUPNVRAD(X,11)),U,1)
..; now v tran
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S I=$P(^AUPNVTC(X,0),U,7)
...Q:I=""
...I $$ICD^BGP5UTL2(I,T,1) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,2)_" "_$P($$CPT^ICPTCOD(I,(9999999-$P(ED,"."))),U,3)
..;now check V PROCEDURE
..S T=$O(^ATXAX("B","BGP CMS CT SCAN PROC",0))
..I 'T W BGPBOMB
..S X=0 F S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X D
...I $$ICD^BGP5UTL2($P(^AUPNVPRC(X,0),U),T,0) S C=C+1,BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$P(ED,"."))_" "_$P($$ICDOP^BGP5UTL2($P(^AUPNVPRC(X,0),U),(9999999-$P(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
.Q
Q
;
ABGPO(P,BD,ED,BGPY) ;EP
;get all O2 measurements on or after admission date
NEW BGPC,X,N,E,Y,T,D,C,BGPLT,L,J
S BGPC=0
K BGPG S Y="BGPG(",X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED) 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
.Q:$P($G(^AUPNVMSR(Y,2)),U,1)
.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^BGP5UTL2(C,T,1)
.S D=$P(^AUPNVCPT(X,0),U,3),D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BD
.Q:D>ED
.S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$P($$CPT^ICPTCOD(C),U,2)_" "_$P($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP5UTL(D)
.Q
;now check v tran
S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S C=$P(^AUPNVTC(X,0),U,7)
.Q:C=""
.Q:'$$ICD^BGP5UTL2(C,T,1)
.S D=$P(^AUPNVTC(X,0),U,3),D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BD
.Q:D>ED
.S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$P($$CPT^ICPTCOD(C),U,2)_" "_$P($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP5UTL(D)
.Q
;now check for lab tests
S T=$O(^ATXAX("B","BGP CMS ABG LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CMS ABG TESTS",0))
S B=9999999-BD,E=9999999-ED S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP5UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP5D21(J,T)
...S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP5UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4)
...Q
Q
ADMDX(H,T) ;EP
S T=$O(^ATXAX("B",T,0))
I 'T Q ""
NEW I
S I=$P($G(^AUPNVINP(H,0)),U,12)
I '$$ICD^BGP5UTL2(I,T,9) Q ""
Q 1_U_$P($$ICDDX^BGP5UTL2(I),U,2)
;
ERPNEU(P,BDATE,EDATE,T) ;EP - did patient have an er visit from bdate to edate without a DX in taxonomy T?
S T=$O(^ATXAX("B",T,0))
I 'T Q ""
NEW BGPG,A,B,E,G,X,I,BGPC
K BGPG,BGPY
S BGPC=0
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q "0^Patient had no ER Visit"
K BGPC S X=0,(G,E,B)="" F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$$CLINIC^APCLV(V,"C")'=30
.S B=1,BGPC(V)=""
I 'B Q "0^Patient had no ER Visit"
S (V,G,E)="" F S V=$O(BGPC(V)) Q:V=""!(E) D
.S A=0,G="" F S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A D
..S I=$P($G(^AUPNVPOV(A,0)),U) Q:'I
..I $$ICD^BGP5UTL2(I,T,9) S E=1 Q
.I 'E S G=0_U_"ER Visit: "_$$DATE^BGP5UTL($P($P(^AUPNVSIT(V,0),U),"."))
I E Q "1^No"
Q G
;
PNEUMODX(V) ;EP
NEW C,T,X,G,I,C
S C=$$PRIMPOV^APCLV(V,"I")
I C="" Q "" ;no primary dx
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
I $$ICD^BGP5UTL2(C,T,9) Q $P($$ICDDX^BGP5UTL2(C),U,2)_" (Primary) "_$$PRIMPOV^APCLV(V,"N") ;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^BGP5UTL2(C,T,9) Q "" ;resp failure not primary pov
S C=$P($$ICDDX^BGP5UTL2(C),U,2)_" (Primary) "_$$PRIMPOV^APCLV(V,"N")
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
S (X,G)="" 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^BGP5UTL2(I,T,9)
.S G=$P($$ICDDX^BGP5UTL2(I),U,2)_" (Secondary) "_$$VAL^XBDIQ1(9000010.07,X,.04)
.Q
I G]"" Q C_U_G
Q ""
;
LVADEX(P,BD,ED) ;EP
NEW X
S X=$$LASTPRC^BGP5UTL1(P,"BGP LVAD/HEART TRANSPLANT PROC",BD,ED)
Q X
;
HFDX(V) ;EP
NEW C,T
S C=$$PRIMPOV^APCLV(V,"I")
I C="" Q 0 ;no primary dx
S T=$O(^ATXAX("B","BGP CMS HEART FAILURE DXS",0))
I 'T Q
Q $$ICD^BGP5UTL2(C,T,9)
;
COMFORT(P,BDATE,EDATE) ;EP - any V66.7 on this visit? or during hospital stay?
NEW X
S X=$$LASTDX^BGP5UTL1(DFN,"BGP PALLIATIVE CARE DXS",BDATE,EDATE)
I X="" Q ""
Q $P(X,U,2)_" "_$$DATE^BGP5UTL($P(X,U,3))
;
DODA(V,H) ;EP was discharge day of or day after admission
I $G(V)="" Q 0
I $G(H)="" Q 0
I $P($P(^AUPNVSIT(V,0),U),".")=$P($P(^AUPNVINP(H,0),U),".") Q 1
NEW X
S X=$$FMADD^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),1)
I X=$P($P(^AUPNVINP(H,0),U),".") Q 1
Q 0
;
DDA(V,H) ;EP - was patient discharged on the day of arrival
I $G(V)="" Q 0
I $G(H)="" Q 0
I $P($P(^AUPNVSIT(V,0),U),".")=$P($P(^AUPNVINP(H,0),U),".") Q 1
Q 0
;
DEATHAMA(H) ;EP was discharge death or AMA?
NEW X
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
I X=4 Q 1
I X=5 Q 1
I X=6 Q 1
I X=7 Q 1
Q 0
;
REGDSCH(H) ;EP
NEW X
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=1 Q 1
Q 0
;
AMA(H,D) ;EP
NEW X
I $P($P($G(^AUPNVINP(H,0)),U),".")=D Q 0
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
;
AMIDX(V) ;EP - AMI DX?
NEW C,T
S C=$$PRIMPOV^APCLV(V,"I")
I C="" Q 0 ;no primary dx
S T=$O(^ATXAX("B","BGP CMS AMI DXS",0))
I 'T Q
Q $$ICD^BGP5UTL2(C,T,9)
;
EXPIRED(H,D) ;
NEW X
I $P($P($G(^AUPNVINP(H,0)),U),".")=D Q 0
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) ;EP - RETURN DSCH DATE IN INTERNAL FORMAT
Q $P($P(^AUPNVINP(H,0),U),".")
;
TRANSIN(H) ;EP
NEW X
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) ;EP - was this a transfer out?
NEW X
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
;
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")
;----------
;
GETMEDS(P,BGPMBD,BGPMED,TAX1,TAX2,TAX3,EXP,ADM,BGPDNAME,BGPC,LAST) ;EP
K ^TMP($J,"MEDS")
S LAST=$G(LAST)
NEW BGPC1,T,T1,T2,X,Y,G,D,C,BGPZ
S BGPDNAME=$G(BGPDNAME)
S BGPC1=0 K BGPZ
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPMBD)_"-"_$$FMTE^XLFDT(BGPMED) S E=$$START1^APCLDF(X,Y)
S T="" I TAX1]"" S T=$O(^ATXAX("B",TAX1,0))
S T1="" I TAX2]"" S T1=$O(^ATXAX("B",TAX2,0))
S T2="" I TAX3]"" S T2=$O(^ATXAX("B",TAX3,0))
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
.S C=$P($G(^PSDRUG(D,2)),U,4)
.I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
.I T,$D(^ATXAX(T,21,"B",D)) S G=1
.I BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
.Q:'G
.I $G(EXP) Q:$$EXP(Y,ADM)
.I G=1 D
..S N=$P(^TMP($J,"MEDS",X),U,2)_" "_$P(^AUPNVMED(Y,0),U,5)_" qty: "_$P(^AUPNVMED(Y,0),U,6)_" days: "_$P(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP7UTL($P(^TMP($J,"MEDS",X),U))
..I $P(^AUPNVMED(Y,0),U,8)]"" S N=N_" D/C "_$$DATE^BGP5UTL($P(^AUPNVMED(Y,0),U,8))
..S BGPZ($P(^TMP($J,"MEDS",X),U,2),(9999999-$P(^TMP($J,"MEDS",X),U)))=N
.Q
I 'LAST D
.S N="" F S N=$O(BGPZ(N)) Q:N="" D
..S D=0,D=$O(BGPZ(N,D)) I '$D(BGPY("B",N,D)) S BGPC=BGPC+1,BGPY(BGPC)=BGPZ(N,D),BGPY("B",N,D)=""
I LAST D
.S N="" F S N=$O(BGPZ(N)) Q:N="" D
..S D=0,D=$O(BGPZ(N,D)) S BGPY(D)=BGPZ(N,D)
..S X=$O(BGPY(0)) S X=BGPY(X)
..K BGPY
..S BGPY=X
Q
EXP(Y,ADM) ;
NEW G,V,N,Z,E
S G=0 ;not expired
S N=$P($G(^AUPNVMED(Y,0)),U,7) ;DAYS SUPPLY
S V=$P(^AUPNVMED(Y,0),U,3)
S Z=$S($D(^PSRX("APCC",Y)):$O(^(Y,0)),1:0) I Z D
.S E=$P($G(^PSRX(Z,2)),U,6)
.I E<ADM S G=1 ;prescription expired prior to admission date
I $$FMADD^XLFDT($P($P(^AUPNVSIT(V,0),U),"."),N)<ADM S G=1
Q G
DSCHINST(P,BDATE,EDATE) ;EP - discharge instructions
;patient ed code HF-DCHL
NEW BGPG,X,Y,T,D,%,E
S Y="BGPG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG) Q ""
S (X,D)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S E=$P(^AUTTEDT(T,0),U,2)
.I E="HF-DCHL" S %=$P(^AUTTEDT(T,0),U,1)_" "_$$DATE^BGP5UTL($P(BGPG(X),U)) Q
Q %
BGP5CU ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM ;
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+2 ;
CHESTXRY(P,BDATE,EDATE,BGPY) ;EP
+1 KILL BGPY
+2 IF '$GET(P)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW C,BD,ED,X,Y,D,G,V,I
+6 SET C=0
+7 ;go through visits in a date range for this patient, check cpts
+8 SET ED=(9999999-EDATE)-1
SET BD=9999999-BDATE
SET G=0
+9 SET T=$ORDER(^ATXAX("B","BGP CMS CHEST XRAY CPT",0))
+10 IF 'T
WRITE BGPBOMB
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 IF $$ICD^BGP5UTL2($PIECE(^AUPNVCPT(X,0),U),T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(X,0),U),(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(X,0),U),(9999999-$PIECE(ED,"."))),U,3
)
End DoDot:3
+16 ;now go through v rads
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 SET I=$PIECE(^AUPNVRAD(X,0),U)
IF I=""
QUIT
SET I=$PIECE($GET(^RAMIS(71,I,0)),U,9)
IF I=""
QUIT
+19 IF $$ICD^BGP5UTL2(I,T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,3)_" Impression: "_$PIECE($GET(^AUPNVRAD(X,11))
,U,1)
End DoDot:3
+20 ; now v tran
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+22 SET I=$PIECE(^AUPNVTC(X,0),U,7)
+23 IF I=""
QUIT
+24 IF $$ICD^BGP5UTL2(I,T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,3)
End DoDot:3
+25 ;now check V PROCEDURE
+26 SET T=$ORDER(^ATXAX("B","BGP CMS CHEST XRAY PROC",0))
+27 IF 'T
WRITE BGPBOMB
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+29 IF $$ICD^BGP5UTL2($PIECE(^AUPNVPRC(X,0),U),T,0)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$ICDOP^BGP5UTL2($PIECE(^AUPNVPRC(X,0),U),(9999999-$PIECE(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:3
+30 ;now check V POV
+31 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+32 SET I=$PIECE($GET(^AUPNVPOV(X,0)),U)
+33 IF 'I
QUIT
+34 IF $PIECE($$ICDDX^BGP5UTL2(I),U,2)="V72.5"
IF $$UP^XLFSTR($$VAL^XBDIQ1(9000010.07,X,.04))["CHEST"
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$ICDDX^BGP5UTL2(I,(9999999-$PIECE(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.07,X,.04)
+35 QUIT
End DoDot:3
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
+38 QUIT
+39 ;
CTSCAN(P,BDATE,EDATE,BGPY) ;EP
+1 KILL BGPY
+2 IF '$GET(P)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW C,BD,ED,X,Y,D,G,V,I
+6 SET C=0
+7 ;go through visits in a date range for this patient, check cpts
+8 SET ED=(9999999-EDATE)-1
SET BD=9999999-BDATE
SET G=0
+9 SET T=$ORDER(^ATXAX("B","BGP CMS CT SCAN CPT",0))
+10 IF 'T
WRITE BGPBOMB
+11 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+12 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+15 IF $$ICD^BGP5UTL2($PIECE(^AUPNVCPT(X,0),U),T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(X,0),U),(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(X,0),U),(9999999-$PIECE(ED,"."))),U,3
)
End DoDot:3
+16 ;now go through v rads
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 SET I=$PIECE(^AUPNVRAD(X,0),U)
IF I=""
QUIT
SET I=$PIECE($GET(^RAMIS(71,I,0)),U,9)
IF I=""
QUIT
+19 IF $$ICD^BGP5UTL2(I,T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,3)_" Impression: "_$PIECE($GET(^AUPNVRAD(X,11))
,U,1)
End DoDot:3
+20 ; now v tran
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+22 SET I=$PIECE(^AUPNVTC(X,0),U,7)
+23 IF I=""
QUIT
+24 IF $$ICD^BGP5UTL2(I,T,1)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,2)_" "_$PIECE($$CPT^ICPTCOD(I,(9999999-$PIECE(ED,"."))),U,3)
End DoDot:3
+25 ;now check V PROCEDURE
+26 SET T=$ORDER(^ATXAX("B","BGP CMS CT SCAN PROC",0))
+27 IF 'T
WRITE BGPBOMB
+28 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+29 IF $$ICD^BGP5UTL2($PIECE(^AUPNVPRC(X,0),U),T,0)
SET C=C+1
SET BGPY(ED,C)=$$DATE^BGP5UTL(9999999-$PIECE(ED,"."))_" "_$PIECE($$ICDOP^BGP5UTL2($PIECE(^AUPNVPRC(X,0),U),(9999999-$PIECE(ED,"."))),U,2)_" "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:3
End DoDot:2
+30 QUIT
End DoDot:1
+31 QUIT
+32 ;
ABGPO(P,BD,ED,BGPY) ;EP
+1 ;get all O2 measurements on or after admission date
+2 NEW BGPC,X,N,E,Y,T,D,C,BGPLT,L,J
+3 SET BGPC=0
+4 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,Y)
+5 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+6 IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+7 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+8 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP5UTL($PIECE(BGPG(X),U))_" value: "_N
+9 QUIT
End DoDot:1
+10 ;now check for cpts
+11 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+13 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+14 SET C=$PIECE(^AUPNVCPT(X,0),U)
+15 IF '$$ICD^BGP5UTL2(C,T,1)
QUIT
+16 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+17 IF D<BD
QUIT
+18 IF D>ED
QUIT
+19 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_$PIECE($$CPT^ICPTCOD(C),U,2)_" "_$PIECE($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP5UTL(D)
+20 QUIT
End DoDot:1
+21 ;now check v tran
+22 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET C=$PIECE(^AUPNVTC(X,0),U,7)
+26 IF C=""
QUIT
+27 IF '$$ICD^BGP5UTL2(C,T,1)
QUIT
+28 SET D=$PIECE(^AUPNVTC(X,0),U,3)
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+29 IF D<BD
QUIT
+30 IF D>ED
QUIT
+31 SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT: "_$PIECE($$CPT^ICPTCOD(C),U,2)_" "_$PIECE($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP5UTL(D)
+32 QUIT
End DoDot:1
+33 ;now check for lab tests
+34 SET T=$ORDER(^ATXAX("B","BGP CMS ABG LOINC",0))
+35 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS ABG TESTS",0))
+36 SET B=9999999-BD
SET E=9999999-ED
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+37 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+38 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+39 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+40 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=BGPC+1
SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP5UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+41 IF 'T
QUIT
+42 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+43 IF '$$LOINC^BGP5D21(J,T)
QUIT
+44 SET BGPC=BGPC+1
SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP5UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
+45 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
ADMDX(H,T) ;EP
+1 SET T=$ORDER(^ATXAX("B",T,0))
+2 IF 'T
QUIT ""
+3 NEW I
+4 SET I=$PIECE($GET(^AUPNVINP(H,0)),U,12)
+5 IF '$$ICD^BGP5UTL2(I,T,9)
QUIT ""
+6 QUIT 1_U_$PIECE($$ICDDX^BGP5UTL2(I),U,2)
+7 ;
ERPNEU(P,BDATE,EDATE,T) ;EP - did patient have an er visit from bdate to edate without a DX in taxonomy T?
+1 SET T=$ORDER(^ATXAX("B",T,0))
+2 IF 'T
QUIT ""
+3 NEW BGPG,A,B,E,G,X,I,BGPC
+4 KILL BGPG,BGPY
+5 SET BGPC=0
+6 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+7 IF '$DATA(BGPG(1))
QUIT "0^Patient had no ER Visit"
+8 KILL BGPC
SET X=0
SET (G,E,B)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+9 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 IF $$CLINIC^APCLV(V,"C")'=30
QUIT
+13 SET B=1
SET BGPC(V)=""
End DoDot:1
+14 IF 'B
QUIT "0^Patient had no ER Visit"
+15 SET (V,G,E)=""
FOR
SET V=$ORDER(BGPC(V))
IF V=""!(E)
QUIT
Begin DoDot:1
+16 SET A=0
SET G=""
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:2
+17 SET I=$PIECE($GET(^AUPNVPOV(A,0)),U)
IF 'I
QUIT
+18 IF $$ICD^BGP5UTL2(I,T,9)
SET E=1
QUIT
End DoDot:2
+19 IF 'E
SET G=0_U_"ER Visit: "_$$DATE^BGP5UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:1
+20 IF E
QUIT "1^No"
+21 QUIT G
+22 ;
PNEUMODX(V) ;EP
+1 NEW C,T,X,G,I,C
+2 SET C=$$PRIMPOV^APCLV(V,"I")
+3 ;no primary dx
IF C=""
QUIT ""
+4 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+5 ;primary dx of pneumonia
IF $$ICD^BGP5UTL2(C,T,9)
QUIT $PIECE($$ICDDX^BGP5UTL2(C),U,2)_" (Primary) "_$$PRIMPOV^APCLV(V,"N")
+6 ;PRIMARY of resp failure and seconday of pneumonia
+7 SET T=$ORDER(^ATXAX("B","BGP CMS SEPTI/RESP FAIL DXS",0))
+8 ;resp failure not primary pov
IF '$$ICD^BGP5UTL2(C,T,9)
QUIT ""
+9 SET C=$PIECE($$ICDDX^BGP5UTL2(C),U,2)_" (Primary) "_$$PRIMPOV^APCLV(V,"N")
+10 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+11 SET (X,G)=""
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+13 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+14 SET I=$PIECE(^AUPNVPOV(X,0),U)
+15 IF '$$ICD^BGP5UTL2(I,T,9)
QUIT
+16 SET G=$PIECE($$ICDDX^BGP5UTL2(I),U,2)_" (Secondary) "_$$VAL^XBDIQ1(9000010.07,X,.04)
+17 QUIT
End DoDot:1
+18 IF G]""
QUIT C_U_G
+19 QUIT ""
+20 ;
LVADEX(P,BD,ED) ;EP
+1 NEW X
+2 SET X=$$LASTPRC^BGP5UTL1(P,"BGP LVAD/HEART TRANSPLANT PROC",BD,ED)
+3 QUIT X
+4 ;
HFDX(V) ;EP
+1 NEW C,T
+2 SET C=$$PRIMPOV^APCLV(V,"I")
+3 ;no primary dx
IF C=""
QUIT 0
+4 SET T=$ORDER(^ATXAX("B","BGP CMS HEART FAILURE DXS",0))
+5 IF 'T
QUIT
+6 QUIT $$ICD^BGP5UTL2(C,T,9)
+7 ;
COMFORT(P,BDATE,EDATE) ;EP - any V66.7 on this visit? or during hospital stay?
+1 NEW X
+2 SET X=$$LASTDX^BGP5UTL1(DFN,"BGP PALLIATIVE CARE DXS",BDATE,EDATE)
+3 IF X=""
QUIT ""
+4 QUIT $PIECE(X,U,2)_" "_$$DATE^BGP5UTL($PIECE(X,U,3))
+5 ;
DODA(V,H) ;EP was discharge day of or day after admission
+1 IF $GET(V)=""
QUIT 0
+2 IF $GET(H)=""
QUIT 0
+3 IF $PIECE($PIECE(^AUPNVSIT(V,0),U),".")=$PIECE($PIECE(^AUPNVINP(H,0),U),".")
QUIT 1
+4 NEW X
+5 SET X=$$FMADD^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),1)
+6 IF X=$PIECE($PIECE(^AUPNVINP(H,0),U),".")
QUIT 1
+7 QUIT 0
+8 ;
DDA(V,H) ;EP - was patient discharged on the day of arrival
+1 IF $GET(V)=""
QUIT 0
+2 IF $GET(H)=""
QUIT 0
+3 IF $PIECE($PIECE(^AUPNVSIT(V,0),U),".")=$PIECE($PIECE(^AUPNVINP(H,0),U),".")
QUIT 1
+4 QUIT 0
+5 ;
DEATHAMA(H) ;EP was discharge death or AMA?
+1 NEW X
+2 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+3 IF X=""
QUIT 0
+4 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+5 IF X=3
QUIT 1
+6 IF X=4
QUIT 1
+7 IF X=5
QUIT 1
+8 IF X=6
QUIT 1
+9 IF X=7
QUIT 1
+10 QUIT 0
+11 ;
REGDSCH(H) ;EP
+1 NEW X
+2 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+3 IF X=""
QUIT 0
+4 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+5 IF X=1
QUIT 1
+6 QUIT 0
+7 ;
AMA(H,D) ;EP
+1 NEW X
+2 IF $PIECE($PIECE($GET(^AUPNVINP(H,0)),U),".")=D
QUIT 0
+3 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+4 IF X=""
QUIT 0
+5 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+6 IF X=3
QUIT 1
+7 QUIT 0
+8 ;
AMIDX(V) ;EP - AMI DX?
+1 NEW C,T
+2 SET C=$$PRIMPOV^APCLV(V,"I")
+3 ;no primary dx
IF C=""
QUIT 0
+4 SET T=$ORDER(^ATXAX("B","BGP CMS AMI DXS",0))
+5 IF 'T
QUIT
+6 QUIT $$ICD^BGP5UTL2(C,T,9)
+7 ;
EXPIRED(H,D) ;
+1 NEW X
+2 IF $PIECE($PIECE($GET(^AUPNVINP(H,0)),U),".")=D
QUIT 0
+3 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+4 IF X=""
QUIT 0
+5 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+6 IF X=4!(X=5)!(X=6)!(X=7)
QUIT 1
+7 QUIT 0
+8 ;
DSCH(H) ;EP - RETURN DSCH DATE IN INTERNAL FORMAT
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
+2 ;
TRANSIN(H) ;EP
+1 NEW X
+2 SET X=$PIECE(^AUPNVINP(H,0),U,7)
+3 IF X=""
QUIT 0
+4 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+5 IF X=2!(X=3)
QUIT 1
+6 QUIT 0
+7 ;
TRANS(H) ;EP - was this a transfer out?
+1 NEW X
+2 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+3 IF X=""
QUIT 0
+4 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+5 IF X=2
QUIT 1
+6 QUIT 0
+7 ;
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 ;----------
+3 ;
GETMEDS(P,BGPMBD,BGPMED,TAX1,TAX2,TAX3,EXP,ADM,BGPDNAME,BGPC,LAST) ;EP
+1 KILL ^TMP($JOB,"MEDS")
+2 SET LAST=$GET(LAST)
+3 NEW BGPC1,T,T1,T2,X,Y,G,D,C,BGPZ
+4 SET BGPDNAME=$GET(BGPDNAME)
+5 SET BGPC1=0
KILL BGPZ
+6 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPMBD)_"-"_$$FMTE^XLFDT(BGPMED)
SET E=$$START1^APCLDF(X,Y)
+7 SET T=""
IF TAX1]""
SET T=$ORDER(^ATXAX("B",TAX1,0))
+8 SET T1=""
IF TAX2]""
SET T1=$ORDER(^ATXAX("B",TAX2,0))
+9 SET T2=""
IF TAX3]""
SET T2=$ORDER(^ATXAX("B",TAX3,0))
+10 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+11 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+12 SET G=0
+13 SET D=$PIECE(^AUPNVMED(Y,0),U)
+14 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+15 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
+16 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+17 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=1
+18 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
+19 IF BGPDNAME]""
IF $PIECE(^PSDRUG(D,0),U)[BGPDNAME
SET G=1
+20 IF 'G
QUIT
+21 IF $GET(EXP)
IF $$EXP(Y,ADM)
QUIT
+22 IF G=1
Begin DoDot:2
+23 SET N=$PIECE(^TMP($JOB,"MEDS",X),U,2)_" "_$PIECE(^AUPNVMED(Y,0),U,5)_" qty: "_$PIECE(^AUPNVMED(Y,0),U,6)_" days: "_$PIECE(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP7UTL($PIECE(^TMP($JOB,"MEDS",X),U))
+24 IF $PIECE(^AUPNVMED(Y,0),U,8)]""
SET N=N_" D/C "_$$DATE^BGP5UTL($PIECE(^AUPNVMED(Y,0),U,8))
+25 SET BGPZ($PIECE(^TMP($JOB,"MEDS",X),U,2),(9999999-$PIECE(^TMP($JOB,"MEDS",X),U)))=N
End DoDot:2
+26 QUIT
End DoDot:1
+27 IF 'LAST
Begin DoDot:1
+28 SET N=""
FOR
SET N=$ORDER(BGPZ(N))
IF N=""
QUIT
Begin DoDot:2
+29 SET D=0
SET D=$ORDER(BGPZ(N,D))
IF '$DATA(BGPY("B",N,D))
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPZ(N,D)
SET BGPY("B",N,D)=""
End DoDot:2
End DoDot:1
+30 IF LAST
Begin DoDot:1
+31 SET N=""
FOR
SET N=$ORDER(BGPZ(N))
IF N=""
QUIT
Begin DoDot:2
+32 SET D=0
SET D=$ORDER(BGPZ(N,D))
SET BGPY(D)=BGPZ(N,D)
+33 SET X=$ORDER(BGPY(0))
SET X=BGPY(X)
+34 KILL BGPY
+35 SET BGPY=X
End DoDot:2
End DoDot:1
+36 QUIT
EXP(Y,ADM) ;
+1 NEW G,V,N,Z,E
+2 ;not expired
SET G=0
+3 ;DAYS SUPPLY
SET N=$PIECE($GET(^AUPNVMED(Y,0)),U,7)
+4 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+5 SET Z=$SELECT($DATA(^PSRX("APCC",Y)):$ORDER(^(Y,0)),1:0)
IF Z
Begin DoDot:1
+6 SET E=$PIECE($GET(^PSRX(Z,2)),U,6)
+7 ;prescription expired prior to admission date
IF E<ADM
SET G=1
End DoDot:1
+8 IF $$FMADD^XLFDT($PIECE($PIECE(^AUPNVSIT(V,0),U),"."),N)<ADM
SET G=1
+9 QUIT G
DSCHINST(P,BDATE,EDATE) ;EP - discharge instructions
+1 ;patient ed code HF-DCHL
+2 NEW BGPG,X,Y,T,D,%,E
+3 SET Y="BGPG("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG)
QUIT ""
+6 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET E=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF E="HF-DCHL"
SET %=$PIECE(^AUTTEDT(T,0),U,1)_" "_$$DATE^BGP5UTL($PIECE(BGPG(X),U))
QUIT
End DoDot:1
+12 QUIT %
