BGP0C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
ABGPO1(P,BGPA,BGPD,BGPY) ;EP
;get all O2 measurements on or after admission date
S BGPC=0
NEW BD,ED
S BD=$$FMADD^XLFDT(BGPA,-1),ED=$$FMADD^XLFDT(BGPA,1)
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^BGP0UTL($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),".")
.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^BGP0UTL(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^ATXCHK(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^BGP0UTL(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^BGP0UTL((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^BGP0D21(J,T)
...S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP0UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4)
...Q
Q
BGP0C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
ABGPO1(P,BGPA,BGPD,BGPY) ;EP
+1 ;get all O2 measurements on or after admission date
+2 SET BGPC=0
+3 NEW BD,ED
+4 SET BD=$$FMADD^XLFDT(BGPA,-1)
SET ED=$$FMADD^XLFDT(BGPA,1)
+5 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL MEAS O2;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(X,Y)
+6 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+7 IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+8 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+9 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_" value: "_N
+10 QUIT
End DoDot:1
+11 ;now check for cpts
+12 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+14 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+15 SET C=$PIECE(^AUPNVCPT(X,0),U)
+16 IF '$$ICD^ATXCHK(C,T,1)
QUIT
+17 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+18 IF D<BD
QUIT
+19 IF D>ED
QUIT
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_$PIECE($$CPT^ICPTCOD(C),U,2)_" "_$PIECE($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP0UTL(D)
+21 QUIT
End DoDot:1
+22 ;now check v tran
+23 SET T=$ORDER(^ATXAX("B","BGP CMS ABG CPTS",0))
+24 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+25 IF '$DATA(^AUPNVTC(X,0))
QUIT
+26 SET C=$PIECE(^AUPNVTC(X,0),U,7)
+27 IF C=""
QUIT
+28 IF '$$ICD^ATXCHK(C,T,1)
QUIT
+29 SET D=$PIECE(^AUPNVTC(X,0),U,3)
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+30 IF D<BD
QUIT
+31 IF D>ED
QUIT
+32 SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT: "_$PIECE($$CPT^ICPTCOD(C),U,2)_" "_$PIECE($$CPT^ICPTCOD(C,D),U,3)_" "_$$DATE^BGP0UTL(D)
+33 QUIT
End DoDot:1
+34 ;now check for lab tests
+35 SET T=$ORDER(^ATXAX("B","BGP CMS ABG LOINC",0))
+36 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS ABG TESTS",0))
+37 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
+38 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+39 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+40 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+41 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^BGP0UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+42 IF 'T
QUIT
+43 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+44 IF '$$LOINC^BGP0D21(J,T)
QUIT
+45 SET BGPC=BGPC+1
SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP0UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
+46 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT
