BGP6C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
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
.S N=$P(^AUPNVMSR(Y,0),U,4)
.S BGPC=BGPC+1,BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP6UTL($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),U,3)_" "_$$DATE^BGP6UTL(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),U,3)_" "_$$DATE^BGP6UTL(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^BGP6UTL((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^BGP6D21(J,T)
...S BGPC=BGPC+1,BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP6UTL((9999999-D))_" value: "_$P(^AUPNVLAB(X,0),U,4)
...Q
Q
BGP6C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+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 SET N=$PIECE(^AUPNVMSR(Y,0),U,4)
+8 SET BGPC=BGPC+1
SET BGPY(BGPC)="MEASUREMENT O2: "_$$DATE^BGP6UTL($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^ATXCHK(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),U,3)_" "_$$DATE^BGP6UTL(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^ATXCHK(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),U,3)_" "_$$DATE^BGP6UTL(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^BGP6UTL((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^BGP6D21(J,T)
QUIT
+44 SET BGPC=BGPC+1
SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP6UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
+45 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+46 QUIT
