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

BGP9C31.m

Go to the documentation of this file.
  1. BGP9C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
  1. ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
  1. ;
  1. ABGPO1(P,BGPA,BGPD,BGPY) ;EP
  1. ;get all O2 measurements on or after admission date
  1. S BGPC=0
  1. NEW BD,ED
  1. S BD=$$FMADD^XLFDT(BGPA,-1),ED=$$FMADD^XLFDT(BGPA,1)
  1. K BGPG S Y="BGPG(",X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED) S E=$$START1^APCLDF(X,Y)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$P(^AUPNVMSR(Y,0),U,4)
  1. .S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" value: "_N
  1. .Q
  1. ;now check for cpts
  1. S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))
  1. S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
  1. .Q:'$D(^AUPNVCPT(X,0))
  1. .S C=$P(^AUPNVCPT(X,0),U)
  1. .Q:'$$ICD^ATXCHK(C,T,1)
  1. .S D=$P(^AUPNVCPT(X,0),U,3),D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .Q:D<BD
  1. .Q:D>ED
  1. .S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_$P($$CPT^ICPTCOD(C),U,2)_" "_$P($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP9UTL(D)
  1. .Q
  1. ;now check v tran
  1. S T=$O(^ATXAX("B","BGP CMS ABG CPTS",0))
  1. S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
  1. .Q:'$D(^AUPNVTC(X,0))
  1. .S C=$P(^AUPNVTC(X,0),U,7)
  1. .Q:C=""
  1. .Q:'$$ICD^ATXCHK(C,T,1)
  1. .S D=$P(^AUPNVTC(X,0),U,3),D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .Q:D<BD
  1. .Q:D>ED
  1. .S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT: "_$P($$CPT^ICPTCOD(C),U,2)_" "_$P($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP9UTL(D)
  1. .Q
  1. ;now check for lab tests
  1. S T=$O(^ATXAX("B","BGP CMS ABG LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP CMS ABG TESTS",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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^BGP9UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4) Q
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP9D21(J,T)
  1. ...S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP9UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4)
  1. ...Q
  1. Q