BGP5C12 ; IHS/CMI/LAB - calc CMS indicators 26 Sep 2004 11:28 AM ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
EN ;EP
K BGPDATA
ALLALG ;
I BGPIND=3 G ALLRX
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,15,"ALL Allergies from Problem List:")=""
K BGPDATA
D ALLALG1(DFN,$$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,15,"ALL Allergies from Problem List:",X)=BGPDATA(X)
ALLALGA ;
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,16,"ALL Allergies from Allergy Tracking:")=""
K BGPDATA
D ALLALGA1(DFN,$$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,16,"ALL Allergies from Allergy Tracking:",X)=BGPDATA(X)
ALLRX ;
S V=$P($P(BGPVSIT0,U),"."),Z="Last of each drug dispensed "_$$DATE^BGP5UTL($$FMADD^XLFDT(V,-365))_"-"_$$DATE^BGP5UTL($$FMADD^XLFDT($$DSCH(BGPVINP),30))_":"
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z)=""
K BGPDATA
D ALLRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S V=$P($P(BGPVSIT0,U),"."),Z="Last of each drug dispensed "_$$DATE^BGP5UTL($$FMADD^XLFDT(V,-365))_"-"_$$DATE^BGP5UTL($$FMADD^XLFDT($$DSCH(BGPVINP),30))_":"
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z,X)=BGPDATA(X)
ALLINPM ;
K BGPY,BGPDATA
S V=$P($P(BGPVSIT0,U),"."),Z="ALL Unit Dose/IV Meds during Hospital Stay: "_$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))_":"
S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z)=""
K BGPDATA
D IVUD(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),,.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S V=$P($P(BGPVSIT0,U),"."),Z="ALL Unit Dose/IV Meds during Hospital Stay: "_$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))_":"
.S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z,X)=BGPDATA(X)
Q
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
ALLALG1(P,BGPD,BGPY) ;
;get all ALLERGIES FROM PROBLEM LIST UP THROUGH DATE OF DISCHARGE ADDED
NEW ED,BD,BGPG,BGPC,X,Y,Z,N
;BGPD is discharge date
S BGPC=0
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:'X D
.S I=$P($$ICDDX^ICDCODE(+^AUPNPROB(X,0)),U,2) ;$P(^ICD9(+^AUPNPROB(X,0),0),U,1)
.S Z=$$PROBACHK(I,X)
.Q:Z=0
.S D=$P(^AUPNPROB(X,0),U,8)
.Q:D>BGPD
.I Z=2 D Q
..S BGPC=BGPC+1,BGPY(BGPC)="NO ALLERGY NOTED ON "_$$DATE^BGP5UTL(D)
.S N=$P(^AUTNPOV(+$P(^AUPNPROB(X,0),U,5),0),U,1)
.I N="" S N="???"
.S BGPC=BGPC+1,BGPY(BGPC)="["_I_"] "_N_" "_$$DATE^BGP5UTL(D)
.Q
Q
ALLALGA1(P,BGPD,BGPY) ;all allergies from the allergy tracking system
;
;now check allergy tracking
S BGPC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($G(^GMR(120.8,X,0)),U,26)>BGPD ;entered after discharge date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.S BGPC=BGPC+1,BGPY(BGPC)=N_" "_$$DATE^BGP5UTL($P(^GMR(120.8,X,0),U,4))
Q
PROBACHK(I,X) ;checking for allergy codes
I I="692.3" Q 1
I I="693.0" Q 1
I I="995.0" Q 1
I I=995.2 Q 1
I (+I'<999.4),(+I'>999.8) Q 1
I I?1"V14."1E Q 1
I I="692.5" Q 1
I I="693.1" Q 1
I I["V15.0" Q 1
I $E(I,1,3)=692,I'="692.9" Q 1
I I="693.8" Q 1
I I="693.9" Q 1
I I="989.5" Q 1
I I="989.82" Q 1
I I="995.3" Q 1
I $P(^AUPNPROB(X,0),U,5)="" Q 0
S N=$P(^AUTNPOV($P(^AUPNPROB(X,0),U,5),0),U)
I I="799.9"!(I="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") Q 2
Q 0
ALLRX1(P,BGPA,BGPD,BGPY) ;
NEW BGPG,BGPC,X,Y,Z,E,BD,ED
S BGPC=0
K ^TMP($J,"A")
S ED=$$FMADD^XLFDT(BGPD,30),ED=9999999-ED,ED=ED-1
S BD=$$FMADD^XLFDT(BGPD,-365),BD=9999999-BD
S D=ED F S D=$O(^AUPNVMED("AA",P,D)) Q:D'=+D!(D>BD) D
.S N=0 F S N=$O(^AUPNVMED("AA",P,D,N)) Q:N'=+N D
..S C=$P($G(^AUPNVMED(N,0)),U)
..Q:C=""
..Q:'$D(^PSDRUG(C,0))
..S C=$P(^PSDRUG(C,0),U)
..S ^TMP($J,"A",C,D)=N
..Q
S D="" F S D=$O(^TMP($J,"A",D)) Q:D="" D
.S A=$O(^TMP($J,"A",D,0))
.S B=9999999-A
.S Y=^TMP($J,"A",D,A)
.S BGPC=BGPC+1,BGPY(BGPC)=D_" "_$P(^AUPNVMED(Y,0),U,5)_" qty: "_$P(^AUPNVMED(Y,0),U,6)_" days: "_$P(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP5UTL(B)
.Q
K ^TMP($J,"A")
K BGPG
Q
;
IVUD(P,BD,ED,TAX,BGPY) ;EP
;p - patient
;bd - beg date
;ed - ending date
;BGPY - return array
;tax - taxonomy ien
NEW C,X,E,D
S TAX=$G(TAX)
S C=0
S X=0 F S X=$O(^PS(55,P,5,X)) Q:X'=+X D
.S D=$P($G(^PS(55,P,5,X,.1)),U)
.Q:D=""
.I TAX Q:'$D(^ATXAX(TAX,21,"B",D))
.S E=$P($P($G(^PS(55,P,5,X,2)),U,2),".",1)
.Q:E>ED
.Q:E<BD
.S C=C+1,BGPY(C)="Unit Dose: "_$P(^PS(50.3,D,0),U)_" Date: "_$$DATE^BGP5UTL(E)
.Q
S X=0 F S X=$O(^PS(55,P,"IV",X)) Q:X'=+X D
.S E=$P(^PS(55,P,"IV",X,0),U,2),E=$P(E,".")
.Q:E>ED
.Q:E<BD
.S D=$P($G(^PS(55,P,"IV",X,6)),U)
.Q:D=""
.I TAX Q:'$D(^ATXAX(TAX,21,"B",D))
.S C=C+1,BGPY(C)="IV: "_$P(^PS(50.3,D,0),U)_" Date: "_$$DATE^BGP5UTL(E)
.Q
Q
BGP5C12 ; IHS/CMI/LAB - calc CMS indicators 26 Sep 2004 11:28 AM ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
EN ;EP
+1 KILL BGPDATA
ALLALG ;
+1 IF BGPIND=3
GOTO ALLRX
+2 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,15,"ALL Allergies from Problem List:")=""
+3 KILL BGPDATA
+4 DO ALLALG1(DFN,$$DSCH(BGPVINP),.BGPDATA)
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,15,"ALL Allergies from Problem List:",X)=BGPDATA(X)
End DoDot:1
ALLALGA ;
+1 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,16,"ALL Allergies from Allergy Tracking:")=""
+2 KILL BGPDATA
+3 DO ALLALGA1(DFN,$$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,16,"ALL Allergies from Allergy Tracking:",X)=BGPDATA(X)
End DoDot:1
ALLRX ;
+1 SET V=$PIECE($PIECE(BGPVSIT0,U),".")
SET Z="Last of each drug dispensed "_$$DATE^BGP5UTL($$FMADD^XLFDT(V,-365))_"-"_$$DATE^BGP5UTL($$FMADD^XLFDT($$DSCH(BGPVINP),30))_":"
+2 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z)=""
+3 KILL BGPDATA
+4 DO ALLRX1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+5 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET V=$PIECE($PIECE(BGPVSIT0,U),".")
SET Z="Last of each drug dispensed "_$$DATE^BGP5UTL($$FMADD^XLFDT(V,-365))_"-"_$$DATE^BGP5UTL($$FMADD^XLFDT($$DSCH(BGPVINP),30))_":"
+7 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z,X)=BGPDATA(X)
End DoDot:1
ALLINPM ;
+1 KILL BGPY,BGPDATA
+2 SET V=$PIECE($PIECE(BGPVSIT0,U),".")
SET Z="ALL Unit Dose/IV Meds during Hospital Stay: "_$$DATE^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))_":"
+3 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z)=""
+4 KILL BGPDATA
+5 DO IVUD(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),,.BGPDATA)
+6 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET V=$PIECE($PIECE(BGPVSIT0,U),".")
SET Z="ALL Unit Dose/IV Meds during Hospital Stay: "_$$DATE^BGP5UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))_":"
+8 SET ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,17,Z,X)=BGPDATA(X)
End DoDot:1
+9 QUIT
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
ALLALG1(P,BGPD,BGPY) ;
+1 ;get all ALLERGIES FROM PROBLEM LIST UP THROUGH DATE OF DISCHARGE ADDED
+2 NEW ED,BD,BGPG,BGPC,X,Y,Z,N
+3 ;BGPD is discharge date
+4 SET BGPC=0
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF 'X
QUIT
Begin DoDot:1
+6 ;$P(^ICD9(+^AUPNPROB(X,0),0),U,1)
SET I=$PIECE($$ICDDX^ICDCODE(+^AUPNPROB(X,0)),U,2)
+7 SET Z=$$PROBACHK(I,X)
+8 IF Z=0
QUIT
+9 SET D=$PIECE(^AUPNPROB(X,0),U,8)
+10 IF D>BGPD
QUIT
+11 IF Z=2
Begin DoDot:2
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="NO ALLERGY NOTED ON "_$$DATE^BGP5UTL(D)
End DoDot:2
QUIT
+13 SET N=$PIECE(^AUTNPOV(+$PIECE(^AUPNPROB(X,0),U,5),0),U,1)
+14 IF N=""
SET N="???"
+15 SET BGPC=BGPC+1
SET BGPY(BGPC)="["_I_"] "_N_" "_$$DATE^BGP5UTL(D)
+16 QUIT
End DoDot:1
+17 QUIT
ALLALGA1(P,BGPD,BGPY) ;all allergies from the allergy tracking system
+1 ;
+2 ;now check allergy tracking
+3 SET BGPC=0
+4 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;entered after discharge date
IF $PIECE($GET(^GMR(120.8,X,0)),U,26)>BGPD
QUIT
+6 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+7 SET BGPC=BGPC+1
SET BGPY(BGPC)=N_" "_$$DATE^BGP5UTL($PIECE(^GMR(120.8,X,0),U,4))
End DoDot:1
+8 QUIT
PROBACHK(I,X) ;checking for allergy codes
+1 IF I="692.3"
QUIT 1
+2 IF I="693.0"
QUIT 1
+3 IF I="995.0"
QUIT 1
+4 IF I=995.2
QUIT 1
+5 IF (+I'<999.4)
IF (+I'>999.8)
QUIT 1
+6 IF I?1"V14."1E
QUIT 1
+7 IF I="692.5"
QUIT 1
+8 IF I="693.1"
QUIT 1
+9 IF I["V15.0"
QUIT 1
+10 IF $EXTRACT(I,1,3)=692
IF I'="692.9"
QUIT 1
+11 IF I="693.8"
QUIT 1
+12 IF I="693.9"
QUIT 1
+13 IF I="989.5"
QUIT 1
+14 IF I="989.82"
QUIT 1
+15 IF I="995.3"
QUIT 1
+16 IF $PIECE(^AUPNPROB(X,0),U,5)=""
QUIT 0
+17 SET N=$PIECE(^AUTNPOV($PIECE(^AUPNPROB(X,0),U,5),0),U)
+18 IF I="799.9"!(I="V82.9")
IF N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG")
QUIT 2
+19 QUIT 0
ALLRX1(P,BGPA,BGPD,BGPY) ;
+1 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+2 SET BGPC=0
+3 KILL ^TMP($JOB,"A")
+4 SET ED=$$FMADD^XLFDT(BGPD,30)
SET ED=9999999-ED
SET ED=ED-1
+5 SET BD=$$FMADD^XLFDT(BGPD,-365)
SET BD=9999999-BD
+6 SET D=ED
FOR
SET D=$ORDER(^AUPNVMED("AA",P,D))
IF D'=+D!(D>BD)
QUIT
Begin DoDot:1
+7 SET N=0
FOR
SET N=$ORDER(^AUPNVMED("AA",P,D,N))
IF N'=+N
QUIT
Begin DoDot:2
+8 SET C=$PIECE($GET(^AUPNVMED(N,0)),U)
+9 IF C=""
QUIT
+10 IF '$DATA(^PSDRUG(C,0))
QUIT
+11 SET C=$PIECE(^PSDRUG(C,0),U)
+12 SET ^TMP($JOB,"A",C,D)=N
+13 QUIT
End DoDot:2
End DoDot:1
+14 SET D=""
FOR
SET D=$ORDER(^TMP($JOB,"A",D))
IF D=""
QUIT
Begin DoDot:1
+15 SET A=$ORDER(^TMP($JOB,"A",D,0))
+16 SET B=9999999-A
+17 SET Y=^TMP($JOB,"A",D,A)
+18 SET BGPC=BGPC+1
SET BGPY(BGPC)=D_" "_$PIECE(^AUPNVMED(Y,0),U,5)_" qty: "_$PIECE(^AUPNVMED(Y,0),U,6)_" days: "_$PIECE(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP5UTL(B)
+19 QUIT
End DoDot:1
+20 KILL ^TMP($JOB,"A")
+21 KILL BGPG
+22 QUIT
+23 ;
IVUD(P,BD,ED,TAX,BGPY) ;EP
+1 ;p - patient
+2 ;bd - beg date
+3 ;ed - ending date
+4 ;BGPY - return array
+5 ;tax - taxonomy ien
+6 NEW C,X,E,D
+7 SET TAX=$GET(TAX)
+8 SET C=0
+9 SET X=0
FOR
SET X=$ORDER(^PS(55,P,5,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET D=$PIECE($GET(^PS(55,P,5,X,.1)),U)
+11 IF D=""
QUIT
+12 IF TAX
IF '$DATA(^ATXAX(TAX,21,"B",D))
QUIT
+13 SET E=$PIECE($PIECE($GET(^PS(55,P,5,X,2)),U,2),".",1)
+14 IF E>ED
QUIT
+15 IF E<BD
QUIT
+16 SET C=C+1
SET BGPY(C)="Unit Dose: "_$PIECE(^PS(50.3,D,0),U)_" Date: "_$$DATE^BGP5UTL(E)
+17 QUIT
End DoDot:1
+18 SET X=0
FOR
SET X=$ORDER(^PS(55,P,"IV",X))
IF X'=+X
QUIT
Begin DoDot:1
+19 SET E=$PIECE(^PS(55,P,"IV",X,0),U,2)
SET E=$PIECE(E,".")
+20 IF E>ED
QUIT
+21 IF E<BD
QUIT
+22 SET D=$PIECE($GET(^PS(55,P,"IV",X,6)),U)
+23 IF D=""
QUIT
+24 IF TAX
IF '$DATA(^ATXAX(TAX,21,"B",D))
QUIT
+25 SET C=C+1
SET BGPY(C)="IV: "_$PIECE(^PS(50.3,D,0),U)_" Date: "_$$DATE^BGP5UTL(E)
+26 QUIT
End DoDot:1
+27 QUIT
