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

BHSMU2.m

Go to the documentation of this file.
  1. BHSMU2 ;IHS/CIA/MGH - Health Summary Utilities ;17-Mar-2009 16:21;MGH
  1. ;;1.0;HEALTH SUMMARY COMPONENTS;**2**;March 17, 2006
  1. ;===================================================================
  1. ;Taken from APCHSMU2
  1. ; IHS/CMI/LAB - utilities for hmr ; [ 03/29/04 12:27 PM ]
  1. ;;2.0;IHS RPMS/PCC Health Summary;**9,11,12**;JUN 24, 1997
  1. ;=================================================================
  1. ;Patch 2 CSV changes in CPT
  1. ;
  1. LASTTD(P) ;EP
  1. NEW X,E,B,%DT,Y,TDD,D,BHSY
  1. K TDD
  1. I '$$BI^BHSMU1 D LASTTDO
  1. I $$BI^BHSMU1 D LASTTDN
  1. ;now check cpt codes
  1. F %=1:1 S T=$T(TDCPTS+%^BHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""
  1. I '$D(TDD) Q ""
  1. Q 9999999-$O(TDD(0))
  1. LASTTDN ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B=1 S TDD(9999999-D)="" Q
  1. .I B=9 S TDD(9999999-D)="" Q
  1. .I B=20 S TDD(9999999-D)="" Q
  1. .I B=22 S TDD(9999999-D)="" Q
  1. .I B=28 S TDD(9999999-D)="" Q
  1. .I B=35 S TDD(9999999-D)="" Q
  1. .I B=50 S TDD(9999999-D)="" Q
  1. .I B=106 S TDD(9999999-D)="" Q
  1. .I B=107 S TDD(9999999-D)="" Q
  1. .I B=110 S TDD(9999999-D)="" Q
  1. Q
  1. ;;
  1. LASTTDO ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B="04" S TDD(9999999-D)="" Q
  1. .I B=42 S TDD(9999999-D)="" Q
  1. .I B=34 S TDD(9999999-D)="" Q
  1. .I B="03" S TDD(9999999-D)="" Q
  1. .I B="02" S TDD(9999999-D)="" Q
  1. Q
  1. LASTPN(P) ;EP
  1. NEW X,E,B,%DT,Y,TDD,D,BHSY
  1. K TDD
  1. I '$$BI^BHSMU1 D LASTPNO
  1. I $$BI^BHSMU1 D LASTPNN
  1. ;now check cpt codes
  1. F %=1:1 S T=$T(PNCPTS+%^BHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""
  1. I '$D(TDD) Q ""
  1. Q 9999999-($O(TDD(0)))
  1. ;
  1. LASTPNN ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B=33 S TDD(9999999-D)="" Q
  1. .I B=100 S TDD(9999999-D)="" Q
  1. .I B=109 S TDD(9999999-D)="" Q
  1. Q
  1. ;;
  1. LASTPNO ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B=19 S TDD(9999999-D)="" Q
  1. Q
  1. LASTFLU(P) ;EP
  1. NEW X,E,B,%DT,Y,TDD,D,BHSY
  1. K TDD
  1. I '$$BI^BHSMU1 D LASTFLO
  1. I $$BI^BHSMU1 D LASTFLN
  1. ;now check cpt codes
  1. F %=1:1 S T=$T(FLUCPTS+%^BHSMU1) Q:$P(T,";;",2)="" S T=$P(T,";;",2),T=$O(^ICPT("B",T,0)) I T S X=$O(^AUPNVCPT("AA",P,T,0)) I X]"" S TDD(X)=""
  1. K BHSY S %=P_"^LAST DX V04.8",E=$$START1^APCLDF(%,"BHSY(")
  1. I $D(BHSY(1)) S TDD(9999999-$P(BHSY(1),U))=""
  1. K BHSY S %=P_"^LAST DX V04.81",E=$$START1^APCLDF(%,"BHSY(")
  1. I $D(BHSY(1)) S TDD(9999999-$P(BHSY(1),U))=""
  1. K BHSY S %=P_"^LAST DX V06.6",E=$$START1^APCLDF(%,"BHSY(")
  1. I $D(BHSY(1)) S TDD(9999999-$P(BHSY(1),U))=""
  1. K BHSY S %=P_"^LAST PROCEDURE 99.52",E=$$START1^APCLDF(%,"BHSY(")
  1. I $D(BHSY(1)) S TDD(9999999-$P(BHSY(1),U))=""
  1. I '$D(TDD) Q ""
  1. Q 9999999-($O(TDD(0)))
  1. ;
  1. LASTFLN ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B=15 S TDD(9999999-D)="" Q
  1. .I B=16 S TDD(9999999-D)="" Q
  1. .I B=88 S TDD(9999999-D)="" Q
  1. .I B=111 S TDD(9999999-D)="" Q
  1. Q
  1. ;;
  1. LASTFLO ;
  1. S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
  1. .S B=$P(^AUPNVIMM(X,0),U) Q:'B
  1. .Q:'$D(^AUTTIMM(B,0))
  1. .S B=$P(^AUTTIMM(B,0),U,3)
  1. .S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
  1. .S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1. .I B=12 S TDD(9999999-D)="" Q
  1. Q
  1. WH(P,BDATE,EDATE,T,F) ;EP
  1. I '$G(P) Q ""
  1. I '$G(T) Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" Q ""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. ;go through procedures in a date range for this patient, check proc type
  1. NEW D,X,Y,G,V
  1. S (G,V)=0 F S V=$O(^BWPCD("C",P,V)) Q:V=""!(G) D
  1. .Q:'$D(^BWPCD(V,0))
  1. .I $P(^BWPCD(V,0),U,4)'=T Q
  1. .S D=$P(^BWPCD(V,0),U,12)
  1. .Q:D<BDATE
  1. .Q:D>EDATE
  1. .S G=V
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
  1. I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
  1. Q ""
  1. CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
  1. I '$G(P) Q ""
  1. I '$G(T) Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" Q ""
  1. I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
  1. ;go through visits in a date range for this patient, check cpts
  1. NEW D,BD,ED,X,Y,D,G,V
  1. S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  1. F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
  1. .S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
  1. ..Q:'$D(^AUPNVSIT(V,0))
  1. ..Q:'$D(^AUPNVCPT("AD",V))
  1. ..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
  1. ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1. I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1. ;Patch 2 cvs changes
  1. N APCHSVDT
  1. ;I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^ICPT($P(^AUPNVCPT(G,0),U),0),U)
  1. I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V S APCHSVDT=$P(+V,".") Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U),APCHSVDT),U,2)
  1. Q ""