AMHLESM.m

AMHLESM ; IHS/CMI/LAB - calls from within screenman ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8

 ;PATCH 2 - limit meds to 2 years

 ;

 ;CMI/TUCSON/LAB - 10/06/97 - PATCH 1 ADDED CODE TO PROPERLY DISPLAY AXIS IV&V ON PREVIOUS POV DISPLAYS (SUB ROUTINES HPOV AND HPOV1)

 ;*** Lori Butcher - IHS Information Systems Division Tucson, AZ ***

EN1(AMHPAT) ;EP - called from protocol

 Q:'$G(AMHPAT)

 D HMED1

 NEW C S C="Medication List for "_$P(^DPT(AMHPAT,0),U)

 D ARRAY^XBLM("^TMP(""AMHDSPMEDS"",$J,",C)

 K ^TMP("AMHSMEDS",$J),^TMP("AMHDSPMEDS",$J)

 Q

HMED ;EP - display last

 ;display last 2 years worth of meds from V Med

 ;display last 2 years worth of meds from mhss record

 I '$G(AMHPAT) S AMHMSG(1)="Unknown Patient" D HLP^DDSUTL(.AMHMSG) K AMHMSG Q

 D HMED1

 NEW C S C="Medication List for "_$P(^DPT(AMHPAT,0),U)

 D ARRAY^XBLM("^TMP(""AMHDSPMEDS"",$J,",C)

 K ^TMP("AMHDSPMEDS",$J)

REFRESH ;

 S X=0 X ^%ZOSF("RM")

 W $P(DDGLVID,DDGLDEL,8)

 D REFRESH^DDSUTL

 Q

HMED1 ;EP

 ;S (%,%1)=""

 S %=$$FMADD^XLFDT(DT,-731),%1=""

 D GETMEDS^AMHLEMD(AMHPAT,%,%1,"L")

 D GETMHMD

 D SETARRAY

 Q

SETARRAY ;

 K ^TMP("AMHDSPMEDS",$J) S ^TMP("AMHDSPMEDS",$J,0)=0

 ;S X="Displayed is the MEDICATIONS PRESCRIBED data field from the BH data file" D S(X)

 ;S X="for the past 2 years of visits." D S(X)

 ;S X="Also, the last of each type of medication from the PCC Database is displayed." D S(X)

 S X=" " D S(X)

 S X=" " D S(X) S X="*** Medications Prescribed entries in BH Database for last 2 years ***" D S(X)

 S I=0 F  S I=$O(^TMP("AMHSMEDS",$J,"M",I)) Q:I'=+I  S X=^TMP("AMHSMEDS",$J,"M",I) D S(X)

 S X=" " D S(X) S X="The last of each type of medication from the PCC Database is displayed below." D S(X)

 S I=0 F  S I=$O(^TMP("AMHSMEDS",$J,"A",I)) Q:I'=+I  S X=^TMP("AMHSMEDS",$J,"A",I) D S(X)

 Q

GETMHMD ;set array ^TMP("AMHSMEDS",$J,"M" OF MEDS IN MH FILE

 K ^TMP("AMHSMEDS",$J,"M")

 NEW AMHLAST,AMHC S AMHLAST=9999999-(DT-20000),AMHC=0

 NEW I S I=0 F  S I=$O(^AMHREC("AE",AMHPAT,I)) Q:I=""!(I>AMHLAST)  D

 .S X=0 F  S X=$O(^AMHREC("AE",AMHPAT,I,X)) Q:X=""  D

 ..Q:'$D(^AMHREC(X,41,0))

 ..Q:'$$ALLOWVI^AMHUTIL(DUZ,X)

 ..S AMHC=AMHC+1,^TMP("AMHSMEDS",$J,"M",AMHC)=$$FMTE^XLFDT((9999999-$P(I,".")),"2E")

 ..S C=0 F  S C=$O(^AMHREC(X,41,C)) Q:C'=+C  S AMHC=AMHC+1,^TMP("AMHSMEDS",$J,"M",AMHC)=^AMHREC(X,41,C,0)

 ..Q

 Q

S(Y,F,C,T) ;

 I '$G(F) S F=0

 I '$G(T) S T=0

 ;blank lines

 F F=1:1:(T-1) S X=" "_X

 F %=1:1:T S X=" "_Y

 D S1

 Q

S1 ;

 S %=$P(^TMP("AMHDSPMEDS",$J,0),U)+1,$P(^TMP("AMHDSPMEDS",$J,0),U)=%

 S ^TMP("AMHDSPMEDS",$J,%,0)=X

 Q

HPOV ;EP display last visit's povs

 NEW AMHC1,AMHA,AMHMSG,%,AMHA,AMHB,AMHT,AMHV,AMHC,AMHCC,X,S,Y,Z ;CMI/TUCSON/LAB - added X,S,Y,Z patch 1 10/06/97

 Q:'$G(AMHR)

 Q:'$G(AMHPAT)

 S AMHC=$$VAL^XBDIQ1(9002013,DUZ(2),.25) S:'AMHC AMHC=1

 S AMHC1=1,AMHMSG(AMHC1)="Patient's Diagnoses from last "_AMHC_" visit"_$S(AMHC=1:"",1:"s")_":"

 S (AMHA,AMHV,AMHCC)=0 F  S AMHA=$O(^AMHREC("AE",AMHPAT,AMHA)) Q:AMHA'=+AMHA!(AMHV)  D

 .S AMHT=0 F  S AMHT=$O(^AMHREC("AE",AMHPAT,AMHA,AMHT)) Q:AMHT'=+AMHT!(AMHV)  I AMHT'=AMHR,$D(^AMHRPRO("AD",AMHT)) D

 ..I $P($G(^AMHSITE(DUZ(2),0)),U,26) Q:$$NOSHOW(AMHT)

 ..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHT)

 ..S AMHB=0 F  S AMHB=$O(^AMHRPRO("AD",AMHT,AMHB)) Q:AMHB'=+AMHB  D

 ...Q:'$P(^AMHRPRO(AMHB,0),U,3)

 ...S AMHC1=AMHC1+1,AMHMSG(AMHC1)=$$FMTE^XLFDT($P($P(^AMHREC($P(^AMHRPRO(AMHB,0),U,3),0),U),"."),"2E")_"  "_$$VAL^XBDIQ1(9002011.01,AMHB,.01)_"  "_$E($$VAL^XBDIQ1(9002011.01,AMHB,.04),1,52)

 ...;S AMHC1=AMHC1+1,AMHMSG(AMHC1)="Provider: "_$$PPINI^AMHUTIL(AMHT)_" " ;CMI/TUCSON/LAB - removed 1 space patch 1 10/06/97

 ...;I $P(^AMHREC(AMHT,0),U,14)]""!($P(^AMHREC(AMHT,0),U,13)]"") D

 ...;S AMHMSG(AMHC1)=AMHMSG(AMHC1)_"AXIS IV: "_$$VAL^XBDIQ1(9002011,AMHT,.13)_" "_$S($P(^AMHREC(AMHT,0),U,13)]"":$P(^AMHTAXIV($P(^AMHREC(AMHT,0),U,13),0),U,2),1:"")_"    AXIS V: "_$$VAL^XBDIQ1(9002011,AMHT,.14)

 ...;CMI/TUCSON/LAB - 10/06/97 - replaced the 2 lines above with 4 lines below to properly display AXIS IV data  patch 1

 ...;S X=0,S="" F  S X=$O(^AMHREC(AMHT,61,X)) Q:X'=+X  S Y=$P(^AMHREC(AMHT,61,X,0),U),S=S_" "_$P(^AMHTAXIV(Y,0),U)_"-"_$E($P(^AMHTAXIV(Y,0),U,2),1,8)

 ...;S Z="AXIS IV:"_S

 ...;I $P(^AMHREC(AMHT,0),U,14)]"" S Z=Z_" AXIS V: "_$P(^AMHREC(AMHT,0),U,14)

 ...;S AMHMSG(AMHC1)=AMHMSG(AMHC1)_" "_Z

 ...S AMHCC=AMHCC+1 I AMHCC=AMHC S AMHV=AMHT Q

 I 'AMHCC S AMHMSG(1)="No prior diagnoses on file for this patient." G HLP

HLP D HLP^DDSUTL(.AMHMSG)

 K AMHCC

 Q

HPOV1 ;EP called from input template

 NEW C,AMHMSG,%,A,B,R

 Q:'$G(AMHR)

 Q:'$G(AMHPAT)

 S (A,%)=0 F  S A=$O(^AMHREC("AE",AMHPAT,A)) Q:A'=+A!(%)  D

 .S R=0 F  S R=$O(^AMHREC("AE",AMHPAT,A,R)) Q:R'=+R!(%)  I R'=AMHR,$D(^AMHRPRO("AD",R)) S %=R

 I '% W !!,"No prior diagnoses on file for this patient."

 S C=1 W !!,"Patient's Diagnoses from last visit:"

 S B=0 F  S B=$O(^AMHRPRO("AD",%,B)) Q:B'=+B  D

 .;CMI/TUCSON/LAB - 10/06/97 - patch 1 added display of axis iv&v by adding next 4 lines

 .I '$P(^AMHRPRO(B,0),U,3) Q

 .S C=C+1 W !,$$FMTE^XLFDT($P($P(^AMHREC($P(^AMHRPRO(B,0),U,3),0),U),"."),"2E")_"  "_$$VAL^XBDIQ1(9002011.01,B,.01)_"  "_$E($$VAL^XBDIQ1(9002011.01,B,.04),1,52)

 .S X=0,S="" F  S X=$O(^AMHREC(%,61,X)) Q:X'=+X  S Y=$P(^AMHREC(%,61,X,0),U),S=S_" "_$P(^AMHTAXIV(Y,0),U)_"-"_$E($P(^AMHTAXIV(Y,0),U,2),1,8)

 .S Z=" AXIS IV:"_S

 .I $P(^AMHREC(%,0),U,14)]"" S Z=Z_" AXIS V: "_$P(^AMHREC(%,0),U,14) I $P($G(^AMHREC(%,11)),U,15)]"" S Z=Z_"  GAF Scale Type: "_$P($G(^AMHREC(%,11)),U,15)

 .W !,"Provider: ",$$PPINI^AMHUTIL(%),$G(Z)

 .Q

 W !

 Q

NOSHOW(V) ;EP - return 0 if no noshows, 1 if noshow

 Q:'$G(V)

 NEW %,X,P

 S (%,X)=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X  S P=$$VAL^XBDIQ1(9002011.01,X,.01) I P>7.9999&(P<9) S %=1

 Q %

AMHLESM   ; IHS/CMI/LAB - calls from within screenman ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**1**;JUN 18, 2010;Build 8

 +2       ;PATCH 2 - limit meds to 2 years

 +3       ;

 +4       ;CMI/TUCSON/LAB - 10/06/97 - PATCH 1 ADDED CODE TO PROPERLY DISPLAY AXIS IV&V ON PREVIOUS POV DISPLAYS (SUB ROUTINES HPOV AND HPOV1)

 +5       ;*** Lori Butcher - IHS Information Systems Division Tucson, AZ ***

EN1(AMHPAT) ;EP - called from protocol

 +1        IF '$GET(AMHPAT)

               QUIT 

 +2        DO HMED1

 +3        NEW C

           SET C="Medication List for "_$PIECE(^DPT(AMHPAT,0),U)

 +4        DO ARRAY^XBLM("^TMP(""AMHDSPMEDS"",$J,",C)

 +5        KILL ^TMP("AMHSMEDS",$JOB),^TMP("AMHDSPMEDS",$JOB)

 +6        QUIT 

HMED      ;EP - display last

 +1       ;display last 2 years worth of meds from V Med

 +2       ;display last 2 years worth of meds from mhss record

 +3        IF '$GET(AMHPAT)

               SET AMHMSG(1)="Unknown Patient"

               DO HLP^DDSUTL(.AMHMSG)

               KILL AMHMSG

               QUIT 

 +4        DO HMED1

 +5        NEW C

           SET C="Medication List for "_$PIECE(^DPT(AMHPAT,0),U)

 +6        DO ARRAY^XBLM("^TMP(""AMHDSPMEDS"",$J,",C)

 +7        KILL ^TMP("AMHDSPMEDS",$JOB)

REFRESH   ;

 +1        SET X=0

           XECUTE ^%ZOSF("RM")

 +2        WRITE $PIECE(DDGLVID,DDGLDEL,8)

 +3        DO REFRESH^DDSUTL

 +4        QUIT 

HMED1     ;EP

 +1       ;S (%,%1)=""

 +2        SET %=$$FMADD^XLFDT(DT,-731)

           SET %1=""

 +3        DO GETMEDS^AMHLEMD(AMHPAT,%,%1,"L")

 +4        DO GETMHMD

 +5        DO SETARRAY

 +6        QUIT 

SETARRAY  ;

 +1        KILL ^TMP("AMHDSPMEDS",$JOB)

           SET ^TMP("AMHDSPMEDS",$JOB,0)=0

 +2       ;S X="Displayed is the MEDICATIONS PRESCRIBED data field from the BH data file" D S(X)

 +3       ;S X="for the past 2 years of visits." D S(X)

 +4       ;S X="Also, the last of each type of medication from the PCC Database is displayed." D S(X)

 +5        SET X=" "

           DO S(X)

 +6        SET X=" "

           DO S(X)

           SET X="*** Medications Prescribed entries in BH Database for last 2 years ***"

           DO S(X)

 +7        SET I=0

           FOR 

               SET I=$ORDER(^TMP("AMHSMEDS",$JOB,"M",I))

               IF I'=+I

                   QUIT 

               SET X=^TMP("AMHSMEDS",$JOB,"M",I)

               DO S(X)

 +8        SET X=" "

           DO S(X)

           SET X="The last of each type of medication from the PCC Database is displayed below."

           DO S(X)

 +9        SET I=0

           FOR 

               SET I=$ORDER(^TMP("AMHSMEDS",$JOB,"A",I))

               IF I'=+I

                   QUIT 

               SET X=^TMP("AMHSMEDS",$JOB,"A",I)

               DO S(X)

 +10       QUIT 

GETMHMD   ;set array ^TMP("AMHSMEDS",$J,"M" OF MEDS IN MH FILE

 +1        KILL ^TMP("AMHSMEDS",$JOB,"M")

 +2        NEW AMHLAST,AMHC

           SET AMHLAST=9999999-(DT-20000)

           SET AMHC=0

 +3        NEW I

           SET I=0

           FOR 

               SET I=$ORDER(^AMHREC("AE",AMHPAT,I))

               IF I=""!(I>AMHLAST)

                   QUIT 

               Begin DoDot:1

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^AMHREC("AE",AMHPAT,I,X))

                       IF X=""

                           QUIT 

                       Begin DoDot:2

 +5                        IF '$DATA(^AMHREC(X,41,0))

                               QUIT 

 +6                        IF '$$ALLOWVI^AMHUTIL(DUZ,X)

                               QUIT 

 +7                        SET AMHC=AMHC+1

                           SET ^TMP("AMHSMEDS",$JOB,"M",AMHC)=$$FMTE^XLFDT((9999999-$PIECE(I,".")),"2E")

 +8                        SET C=0

                           FOR 

                               SET C=$ORDER(^AMHREC(X,41,C))

                               IF C'=+C

                                   QUIT 

                               SET AMHC=AMHC+1

                               SET ^TMP("AMHSMEDS",$JOB,"M",AMHC)=^AMHREC(X,41,C,0)

 +9                        QUIT 

                       End DoDot:2

               End DoDot:1

 +10       QUIT 

S(Y,F,C,T) ;

 +1        IF '$GET(F)

               SET F=0

 +2        IF '$GET(T)

               SET T=0

 +3       ;blank lines

 +4        FOR F=1:1:(T-1)

               SET X=" "_X

 +5        FOR %=1:1:T

               SET X=" "_Y

 +6        DO S1

 +7        QUIT 

S1        ;

 +1        SET %=$PIECE(^TMP("AMHDSPMEDS",$JOB,0),U)+1

           SET $PIECE(^TMP("AMHDSPMEDS",$JOB,0),U)=%

 +2        SET ^TMP("AMHDSPMEDS",$JOB,%,0)=X

 +3        QUIT 

HPOV      ;EP display last visit's povs

 +1       ;CMI/TUCSON/LAB - added X,S,Y,Z patch 1 10/06/97

           NEW AMHC1,AMHA,AMHMSG,%,AMHA,AMHB,AMHT,AMHV,AMHC,AMHCC,X,S,Y,Z

 +2        IF '$GET(AMHR)

               QUIT 

 +3        IF '$GET(AMHPAT)

               QUIT 

 +4        SET AMHC=$$VAL^XBDIQ1(9002013,DUZ(2),.25)

           IF 'AMHC

               SET AMHC=1

 +5        SET AMHC1=1

           SET AMHMSG(AMHC1)="Patient's Diagnoses from last "_AMHC_" visit"_$SELECT(AMHC=1:"",1:"s")_":"

 +6        SET (AMHA,AMHV,AMHCC)=0

           FOR 

               SET AMHA=$ORDER(^AMHREC("AE",AMHPAT,AMHA))

               IF AMHA'=+AMHA!(AMHV)

                   QUIT 

               Begin DoDot:1

 +7                SET AMHT=0

                   FOR 

                       SET AMHT=$ORDER(^AMHREC("AE",AMHPAT,AMHA,AMHT))

                       IF AMHT'=+AMHT!(AMHV)

                           QUIT 

                       IF AMHT'=AMHR

                           IF $DATA(^AMHRPRO("AD",AMHT))

                               Begin DoDot:2

 +8                                IF $PIECE($GET(^AMHSITE(DUZ(2),0)),U,26)

                                       IF $$NOSHOW(AMHT)

                                           QUIT 

 +9                                IF '$$ALLOWVI^AMHUTIL(DUZ,AMHT)

                                       QUIT 

 +10                               SET AMHB=0

                                   FOR 

                                       SET AMHB=$ORDER(^AMHRPRO("AD",AMHT,AMHB))

                                       IF AMHB'=+AMHB

                                           QUIT 

                                       Begin DoDot:3

 +11                                       IF '$PIECE(^AMHRPRO(AMHB,0),U,3)

                                               QUIT 

 +12                                       SET AMHC1=AMHC1+1

                                           SET AMHMSG(AMHC1)=$$FMTE^XLFDT($PIECE($PIECE(^AMHREC($PIECE(^AMHRPRO(AMHB,0),U,3),0),U),"."),"2E")_"  "_$$VAL^XBDIQ1(9002011.01,AMHB,.01)_"  "_$EXTRACT($$VAL^XBDIQ1(9002011.01,AMHB,.04),1,52)

 +13      ;S AMHC1=AMHC1+1,AMHMSG(AMHC1)="Provider: "_$$PPINI^AMHUTIL(AMHT)_" " ;CMI/TUCSON/LAB - removed 1 space patch 1 10/06/97

 +14      ;I $P(^AMHREC(AMHT,0),U,14)]""!($P(^AMHREC(AMHT,0),U,13)]"") D

 +15      ;S AMHMSG(AMHC1)=AMHMSG(AMHC1)_"AXIS IV: "_$$VAL^XBDIQ1(9002011,AMHT,.13)_" "_$S($P(^AMHREC(AMHT,0),U,13)]"":$P(^AMHTAXIV($P(^AMHREC(AMHT,0),U,13),0),U,2),1:"")_"    AXIS V: "_$$VAL^XBDIQ1(9002011,AMHT,.14)

 +16      ;CMI/TUCSON/LAB - 10/06/97 - replaced the 2 lines above with 4 lines below to properly display AXIS IV data  patch 1

 +17      ;S X=0,S="" F  S X=$O(^AMHREC(AMHT,61,X)) Q:X'=+X  S Y=$P(^AMHREC(AMHT,61,X,0),U),S=S_" "_$P(^AMHTAXIV(Y,0),U)_"-"_$E($P(^AMHTAXIV(Y,0),U,2),1,8)

 +18      ;S Z="AXIS IV:"_S

 +19      ;I $P(^AMHREC(AMHT,0),U,14)]"" S Z=Z_" AXIS V: "_$P(^AMHREC(AMHT,0),U,14)

 +20      ;S AMHMSG(AMHC1)=AMHMSG(AMHC1)_" "_Z

 +21                                       SET AMHCC=AMHCC+1

                                           IF AMHCC=AMHC

                                               SET AMHV=AMHT

                                               QUIT 

                                       End DoDot:3

                               End DoDot:2

               End DoDot:1

 +22       IF 'AMHCC

               SET AMHMSG(1)="No prior diagnoses on file for this patient."

               GOTO HLP

HLP        DO HLP^DDSUTL(.AMHMSG)

 +1        KILL AMHCC

 +2        QUIT 

HPOV1     ;EP called from input template

 +1        NEW C,AMHMSG,%,A,B,R

 +2        IF '$GET(AMHR)

               QUIT 

 +3        IF '$GET(AMHPAT)

               QUIT 

 +4        SET (A,%)=0

           FOR 

               SET A=$ORDER(^AMHREC("AE",AMHPAT,A))

               IF A'=+A!(%)

                   QUIT 

               Begin DoDot:1

 +5                SET R=0

                   FOR 

                       SET R=$ORDER(^AMHREC("AE",AMHPAT,A,R))

                       IF R'=+R!(%)

                           QUIT 

                       IF R'=AMHR

                           IF $DATA(^AMHRPRO("AD",R))

                               SET %=R

               End DoDot:1

 +6        IF '%

               WRITE !!,"No prior diagnoses on file for this patient."

 +7        SET C=1

           WRITE !!,"Patient's Diagnoses from last visit:"

 +8        SET B=0

           FOR 

               SET B=$ORDER(^AMHRPRO("AD",%,B))

               IF B'=+B

                   QUIT 

               Begin DoDot:1

 +9       ;CMI/TUCSON/LAB - 10/06/97 - patch 1 added display of axis iv&v by adding next 4 lines

 +10               IF '$PIECE(^AMHRPRO(B,0),U,3)

                       QUIT 

 +11               SET C=C+1

                   WRITE !,$$FMTE^XLFDT($PIECE($PIECE(^AMHREC($PIECE(^AMHRPRO(B,0),U,3),0),U),"."),"2E")_"  "_$$VAL^XBDIQ1(9002011.01,B,.01)_"  "_$EXTRACT($$VAL^XBDIQ1(9002011.01,B,.04),1,52)

 +12               SET X=0

                   SET S=""

                   FOR 

                       SET X=$ORDER(^AMHREC(%,61,X))

                       IF X'=+X

                           QUIT 

                       SET Y=$PIECE(^AMHREC(%,61,X,0),U)

                       SET S=S_" "_$PIECE(^AMHTAXIV(Y,0),U)_"-"_$EXTRACT($PIECE(^AMHTAXIV(Y,0),U,2),1,8)

 +13               SET Z=" AXIS IV:"_S

 +14               IF $PIECE(^AMHREC(%,0),U,14)]""

                       SET Z=Z_" AXIS V: "_$PIECE(^AMHREC(%,0),U,14)

                       IF $PIECE($GET(^AMHREC(%,11)),U,15)]""

                           SET Z=Z_"  GAF Scale Type: "_$PIECE($GET(^AMHREC(%,11)),U,15)

 +15               WRITE !,"Provider: ",$$PPINI^AMHUTIL(%),$GET(Z)

 +16               QUIT 

               End DoDot:1

 +17       WRITE !

 +18       QUIT 

NOSHOW(V) ;EP - return 0 if no noshows, 1 if noshow

 +1        IF '$GET(V)

               QUIT 

 +2        NEW %,X,P

 +3        SET (%,X)=0

           FOR 

               SET X=$ORDER(^AMHRPRO("AD",V,X))

               IF X'=+X

                   QUIT 

               SET P=$$VAL^XBDIQ1(9002011.01,X,.01)

               IF P>7.9999&(P<9)

                   SET %=1

 +4        QUIT %