AMHRSB2.m

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