- BGP9C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
- ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
- ;
- 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^BGP9UTL($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^BGP9UTL(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^BGP9UTL(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^BGP9UTL((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^BGP9D21(J,T)
- ...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
- Q
- BGP9C31 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
- +1 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009
- +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^BGP9UTL($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,D),U,3)_" "_$$DATE^BGP9UTL(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,D),U,3)_" "_$$DATE^BGP9UTL(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^BGP9UTL((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^BGP9D21(J,T)
- QUIT
- +44 SET BGPC=BGPC+1
- SET BGPY(BGPC)="LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$$DATE^BGP9UTL((9999999-D))_" value: "_$PIECE(^AUPNVLAB(X,0),U,4)
- +45 QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +46 QUIT