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