AMHRSB2 ; IHS/CMI/LAB - list sbirt 24 Aug 2009 6:21 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
;
;
BNI(P,BDATE,EDATE,AMHABNI) ;EP - GET FIRST BNI AVAILABLE ON A VISITS
NEW AMHG,%,E,AMHSC,V,AMHC,T,F,D,R,AMHCT,AMHX,AMHV,AMHVD,AMHIVD,X
K AMHABNI
S AMHSC=0
PCC ;check PCC first
S AMHCT=$O(^ATXAX("B","BGP BNI CPTS",0))
K AMHG
D ALLV^APCLAPIU(P,BDATE,EDATE,"AMHG")
S AMHX=0 F S AMHX=$O(AMHG(AMHX)) Q:AMHX'=+AMHX S AMHV=$P(AMHG(AMHX),U,5) D
.Q:$P(^AUPNVSIT(AMHV,0),U,7)'="A" ;IF SBI ONLY AMBULATORY
.S AMHVD=$$VD^APCLV(AMHV)
PCCCPT .;
.S E=0 F S E=$O(^AUPNVCPT("AD",AMHV,E)) Q:E'=+E D
..S I=$P($G(^AUPNVCPT(E,0)),U,1)
..Q:'I
..Q:'$$ICD^ATXAPI(I,AMHCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S AMHSC=AMHSC+1
..S AMHABNI(AMHVD,AMHSC)=1_"^CPT "_J_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
PCCPTED .;
.S E=0 F S E=$O(^AUPNVPED("AD",AMHV,E)) Q:E'=+E D
..S I=$P($G(^AUPNVPED(E,0)),U,1)
..Q:'I
..S T=$P($G(^AUTTEDT(I,0)),U,2)
..I T="AOD-BNI" G PCS
..Q:$L($P(T,"-",1))'=5
..S I=+$$CODEN^ICPTCOD($P(T,"-",1))
..Q:'$$ICD^ATXAPI(I,AMHCT,1)
PCS ..S AMHSC=AMHSC+1
..S AMHABNI(AMHVD,AMHSC)=1_"^PT ED "_T_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
BH ;CHECK BH VISITS
S AMHC="",T="",F=""
S E=9999999-BDATE,D=9999999-EDATE-1_".99"
F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
BHEX .;
.S T=$$VAL^XBDIQ1(9002011,V,.07)
.I T'="AFTERCARE",T'="OUTPATIENT",T'="INTENSIVE OUTPATIENT",T'="EMERGENCY ROOM",T'="TELE-BEHAVIORAL HEALTH" Q
.S AMHVD=9999999-$P(D,".")
BHCPT .;now add in CPT codes
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X D
..S I=$P($G(^AMHRPROC(X,0)),U,1)
..Q:'I
..Q:'$$ICD^ATXAPI(I,AMHCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S AMHSC=AMHSC+1
..S AMHABNI(AMHVD,AMHSC)=1_"^CPT "_J_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
..Q
BHPTED .;
.S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X D
..S I=$P($G(^AMHREDU(X,0)),U,1)
..Q:'I
..S T=$P($G(^AUTTEDT(I,0)),U,2)
..I T="AOD-BNI" G BHS
..Q:$L($P(T,U,1))'=5
..Q:'$$ICD^ATXAPI($P(T,U,1),AMHCT,1)
BHS ..S AMHSC=AMHSC+1
..S AMHABNI(AMHVD,AMHSC)=1_"^PT ED "_T_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
.Q
Q
LISTS ;EP
D @AMHRSORT
I AMHRSORV="" S AMHRSORV="--"
I $D(AMHRLIST(1)) D
.;this list is for all with any positive screen
.Q:'GPP ;patient had no positives
.S X=0 F S X=$O(AMHASCR(X)) Q:X'=+X D
..S ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST1",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$P(AMHASCR(X),U)_U_$P(AMHASCR(X),U,2)_U_"POSITIVE"_U_$P(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($P(AMHASCR(X),U,7))_U_$P(AMHASCR(X),U,5)_U_$P(AMHASCR(X),U,8)
I $D(AMHRLIST(2)) D
.;this list is for all with any positive screen
.Q:'GPP
.I 'GP0,'GP1,'GP4,'GPT Q ;had none within appropriate time window ;patient had no positives
.S X=0 F S X=$O(AMHASCR(X)) Q:X'=+X D
..S ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST2",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$P(AMHASCR(X),U)_U_$P(AMHASCR(X),U,2)_U_"POSITIVE"_U_$P(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($P(AMHASCR(X),U,7))_U_$P(AMHASCR(X),U,5)_U_$P(AMHASCR(X),U,8)
..Q
I $D(AMHRLIST(3)) D
.;this list is for all with any positive screen
.Q:'GPP
.I 'GP0,'GP1,'GP4,'GPT D ;had none within appropriate time window ;patient had no positives
..S X=0 F S X=$O(AMHASCR(X)) Q:X'=+X D
...S ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST3",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$P(AMHASCR(X),U)_U_$P(AMHASCR(X),U,2)_U_"POSITIVE"_U_$P(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($P(AMHASCR(X),U,7))_U_$P(AMHASCR(X),U,5)_U_$P(AMHASCR(X),U,8)
;
Q
H ;
S AMHRSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
Q
N ;
S AMHRSORV=$P(^DPT(DFN,0),U)
Q
A S AMHRSORV=$$AGE^AUPNPAT(DFN,AMHRBD)
Q
G ;
S AMHRSORV=$$VAL^XBDIQ1(2,DFN,.02)
Q
T ;
S %=$$HRN^AUPNPAT(DFN,DUZ(2))
S %=%+10000000,%=$E(%,7,8)_"-"_+$E(%,2,8)
S AMHRSORV=%
Q
AMHRSB2 ; IHS/CMI/LAB - list sbirt 24 Aug 2009 6:21 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
BNI(P,BDATE,EDATE,AMHABNI) ;EP - GET FIRST BNI AVAILABLE ON A VISITS
+1 NEW AMHG,%,E,AMHSC,V,AMHC,T,F,D,R,AMHCT,AMHX,AMHV,AMHVD,AMHIVD,X
+2 KILL AMHABNI
+3 SET AMHSC=0
PCC ;check PCC first
+1 SET AMHCT=$ORDER(^ATXAX("B","BGP BNI CPTS",0))
+2 KILL AMHG
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"AMHG")
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(AMHG(AMHX))
IF AMHX'=+AMHX
QUIT
SET AMHV=$PIECE(AMHG(AMHX),U,5)
Begin DoDot:1
+5 ;IF SBI ONLY AMBULATORY
IF $PIECE(^AUPNVSIT(AMHV,0),U,7)'="A"
QUIT
+6 SET AMHVD=$$VD^APCLV(AMHV)
PCCCPT ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",AMHV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVCPT(E,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^ATXAPI(I,AMHCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET AMHSC=AMHSC+1
+7 SET AMHABNI(AMHVD,AMHSC)=1_"^CPT "_J_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
End DoDot:2
PCCPTED ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVPED("AD",AMHV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVPED(E,0)),U,1)
+3 IF 'I
QUIT
+4 SET T=$PIECE($GET(^AUTTEDT(I,0)),U,2)
+5 IF T="AOD-BNI"
GOTO PCS
+6 IF $LENGTH($PIECE(T,"-",1))'=5
QUIT
+7 SET I=+$$CODEN^ICPTCOD($PIECE(T,"-",1))
+8 IF '$$ICD^ATXAPI(I,AMHCT,1)
QUIT
PCS SET AMHSC=AMHSC+1
+1 SET AMHABNI(AMHVD,AMHSC)=1_"^PT ED "_T_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
End DoDot:2
End DoDot:1
BH ;CHECK BH VISITS
+1 SET AMHC=""
SET T=""
SET F=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
+3 FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
BHEX ;
+1 SET T=$$VAL^XBDIQ1(9002011,V,.07)
+2 IF T'="AFTERCARE"
IF T'="OUTPATIENT"
IF T'="INTENSIVE OUTPATIENT"
IF T'="EMERGENCY ROOM"
IF T'="TELE-BEHAVIORAL HEALTH"
QUIT
+3 SET AMHVD=9999999-$PIECE(D,".")
BHCPT ;now add in CPT codes
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHRPROC(X,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^ATXAPI(I,AMHCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET AMHSC=AMHSC+1
+7 SET AMHABNI(AMHVD,AMHSC)=1_"^CPT "_J_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
+8 QUIT
End DoDot:2
BHPTED ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHREDU(X,0)),U,1)
+3 IF 'I
QUIT
+4 SET T=$PIECE($GET(^AUTTEDT(I,0)),U,2)
+5 IF T="AOD-BNI"
GOTO BHS
+6 IF $LENGTH($PIECE(T,U,1))'=5
QUIT
+7 IF '$$ICD^ATXAPI($PIECE(T,U,1),AMHCT,1)
QUIT
BHS SET AMHSC=AMHSC+1
+1 SET AMHABNI(AMHVD,AMHSC)=1_"^PT ED "_T_"^"_$$FMTE^XLFDT(AMHVD)_U_AMHVD_U_$$FMDIFF^XLFDT(AMHVD,BDATE)
End DoDot:2
+2 QUIT
End DoDot:1
+3 QUIT
LISTS ;EP
+1 DO @AMHRSORT
+2 IF AMHRSORV=""
SET AMHRSORV="--"
+3 IF $DATA(AMHRLIST(1))
Begin DoDot:1
+4 ;this list is for all with any positive screen
+5 ;patient had no positives
IF 'GPP
QUIT
+6 SET X=0
FOR
SET X=$ORDER(AMHASCR(X))
IF X'=+X
QUIT
Begin DoDot:2
+7 SET ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST1",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$PIECE(AMHASCR(X),U)_U_$PIECE(AMHASCR(X),U,2)_U_"POSITIVE"_U_$PIECE(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($PIECE(AMHASCR(X),U,7))_U_$PIECE(AMHASCR(X),U,5)_U_$PIE
CE(AMHASCR(X),U,8)
End DoDot:2
End DoDot:1
+8 IF $DATA(AMHRLIST(2))
Begin DoDot:1
+9 ;this list is for all with any positive screen
+10 IF 'GPP
QUIT
+11 ;had none within appropriate time window ;patient had no positives
IF 'GP0
IF 'GP1
IF 'GP4
IF 'GPT
QUIT
+12 SET X=0
FOR
SET X=$ORDER(AMHASCR(X))
IF X'=+X
QUIT
Begin DoDot:2
+13 SET ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST2",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$PIECE(AMHASCR(X),U)_U_$PIECE(AMHASCR(X),U,2)_U_"POSITIVE"_U_$PIECE(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($PIECE(AMHASCR(X),U,7))_U_$PIECE(AMHASCR(X),U,5)_U_$PIE
CE(AMHASCR(X),U,8)
+14 QUIT
End DoDot:2
End DoDot:1
+15 IF $DATA(AMHRLIST(3))
Begin DoDot:1
+16 ;this list is for all with any positive screen
+17 IF 'GPP
QUIT
+18 ;had none within appropriate time window ;patient had no positives
IF 'GP0
IF 'GP1
IF 'GP4
IF 'GPT
Begin DoDot:2
+19 SET X=0
FOR
SET X=$ORDER(AMHASCR(X))
IF X'=+X
QUIT
Begin DoDot:3
+20 SET ^XTMP("AMHRSB1",AMHRJ,AMHRH,"LIST3",AMHRSORV,DFN,X)=$$FMTE^XLFDT(X)_U_$PIECE(AMHASCR(X),U)_U_$PIECE(AMHASCR(X),U,2)_U_"POSITIVE"_U_$PIECE(AMHASCR(X),U,4)_U_$$FMTE^XLFDT($PIECE(AMHASCR(X),U,7))_U_$PIECE(AM
HASCR(X),U,5)_U_$PIECE(AMHASCR(X),U,8)
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 QUIT
H ;
+1 SET AMHRSORV=$$HRN^AUPNPAT(DFN,DUZ(2))
+2 QUIT
N ;
+1 SET AMHRSORV=$PIECE(^DPT(DFN,0),U)
+2 QUIT
A SET AMHRSORV=$$AGE^AUPNPAT(DFN,AMHRBD)
+1 QUIT
G ;
+1 SET AMHRSORV=$$VAL^XBDIQ1(2,DFN,.02)
+2 QUIT
T ;
+1 SET %=$$HRN^AUPNPAT(DFN,DUZ(2))
+2 SET %=%+10000000
SET %=$EXTRACT(%,7,8)_"-"_+$EXTRACT(%,2,8)
+3 SET AMHRSORV=%
+4 QUIT
