Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP5C12

BGP5C12.m

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