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 %
