AMHGRU ;IHS/CMI/MAW - AMHG REPORT UTILITIES;
;;4.0;IHS BEHAVIORAL HEALTH;**1,2**;JUN 18, 2010;Build 23
;
;
;
Q
;
DEBUG(AMHRET,AMHSTR) ;-- debugger
D DEBUG^%Serenji("INTAKE^AMHGR(.AMHRET,.AMHSTR)")
Q
;
PCCM(AMHPAT,BD,ED) ;EP -- get pcc medications
S %=$$FMADD^XLFDT(DT,-731),%1=""
D GETMEDS^AMHLEMD(AMHPAT,BD,ED,"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 "_$$FMTE^XLFDT(BD)_" to "_$$FMTE^XLFDT(ED)_" " 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
;
PAD(DATA,LENGTH) ;EP -- SUBRTN to pad length of data
Q $E(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
;
SP(N) ;EP -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
PCCL(PAT,BD,ED,DM) ;EP -- get pcc labs
K ^TMP("AMHLABG",$J)
K ^TMP("AMHLABV",$J)
N BBD,BED,AMHDA,AMHIEN,CNT,AMHOEN,AMHCNT
N AMHTEST,AMHVST,AMHRES,AMHABN,AMHRL,AMHRH,AMHCDT,AMHOP,AMHTSTI,AMHVSTI,AMHCDTI
S BBD=9999999-BD,BED=9999999-(ED+1)
S AMHDA=0 F S AMHDA=$O(^AUPNVLAB("AA",PAT,AMHDA)) Q:'AMHDA D
. S AMHOEN=BED F S AMHOEN=$O(^AUPNVLAB("AA",PAT,AMHDA,AMHOEN)) Q:'AMHOEN!(AMHOEN>BBD) D
.. S AMHIEN=0 F S AMHIEN=$O(^AUPNVLAB("AA",PAT,AMHDA,AMHOEN,AMHIEN)) Q:'AMHIEN D
... S AMHTEST=$$GET1^DIQ(9000010.09,AMHIEN,.01)
... S AMHTSTI=$$GET1^DIQ(9000010.09,AMHIEN,.01,"I")
... S AMHVST=$$GET1^DIQ(9000010.09,AMHIEN,.03)
... S AMHVSTI=9999999-AMHOEN
... S AMHRES=$$GET1^DIQ(9000010.09,AMHIEN,.04)
... S AMHABN=$$GET1^DIQ(9000010.09,AMHIEN,.05)
... S AMHRL=$$GET1^DIQ(9000010.09,AMHIEN,1104)
... S AMHRH=$$GET1^DIQ(9000010.09,AMHIEN,1105)
... S AMHCDT=$$GET1^DIQ(9000010.09,AMHIEN,1201)
... S AMHCDTI=$$GET1^DIQ(9000010.09,AMHIEN,1201,"I")
... S AMHCDTI=9999999-AMHCDTI
... S AMHOP=$$GET1^DIQ(9000010.09,AMHIEN,1202)
... I DM="G" D Q
.... S:'$D(AMHRES(AMHTSTI)) AMHRES(AMHTSTI)=0
.... I $G(AMHRES)]"" S AMHRES(AMHTSTI)=AMHRES(AMHTSTI)+1
.... S:'$D(AMHTEST("EARLY")) AMHTEST("EARLY")=9999999
.... S:'$D(AMHTEST("LAST")) AMHTEST("LAST")=0
.... I AMHVSTI<AMHTEST("EARLY") S AMHTEST("EARLY")=AMHVSTI
.... I AMHVSTI>AMHTEST("LAST") S AMHTEST("LAST")=AMHVSTI
.... S:'$D(AMHCNT(AMHTEST)) AMHCNT(AMHTEST)=0
.... S AMHCNT(AMHTEST)=AMHCNT(AMHTEST)+1
.... S ^TMP("AMHLABG",$J,AMHTEST)=AMHTSTI_U_AMHCNT(AMHTEST)_U_$G(AMHTEST("EARLY"))_U_$G(AMHTEST("LAST"))
... I DM="V" D Q
.... ;S ^TMP("AMHLABV",$J,AMHVST,AMHTEST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP
.... S ^TMP("AMHLABV",$J,AMHCDTI,AMHTEST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP_U_AMHCDT ;v4.0p1 pr781
... S ^TMP("AMHLABV",$J,AMHTEST,AMHVST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP_U_AMHCDT ;v4.0p1 pr781
Q
;
AMHGRU ;IHS/CMI/MAW - AMHG REPORT UTILITIES;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,2**;JUN 18, 2010;Build 23
+2 ;
+3 ;
+4 ;
+5 QUIT
+6 ;
DEBUG(AMHRET,AMHSTR) ;-- debugger
+1 DO DEBUG^%Serenji("INTAKE^AMHGR(.AMHRET,.AMHSTR)")
+2 QUIT
+3 ;
PCCM(AMHPAT,BD,ED) ;EP -- get pcc medications
+1 SET %=$$FMADD^XLFDT(DT,-731)
SET %1=""
+2 DO GETMEDS^AMHLEMD(AMHPAT,BD,ED,"L")
+3 DO GETMHMD
+4 DO SETARRAY
+5 QUIT
+6 ;
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 "_$$FMTE^XLFDT(BD)_" to "_$$FMTE^XLFDT(ED)_" "
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
+4 ;
PAD(DATA,LENGTH) ;EP -- SUBRTN to pad length of data
+1 QUIT $EXTRACT(DATA_$$REPEAT^XLFSTR(" ",LENGTH),1,LENGTH)
+2 ;
SP(N) ;EP -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
PCCL(PAT,BD,ED,DM) ;EP -- get pcc labs
+1 KILL ^TMP("AMHLABG",$JOB)
+2 KILL ^TMP("AMHLABV",$JOB)
+3 NEW BBD,BED,AMHDA,AMHIEN,CNT,AMHOEN,AMHCNT
+4 NEW AMHTEST,AMHVST,AMHRES,AMHABN,AMHRL,AMHRH,AMHCDT,AMHOP,AMHTSTI,AMHVSTI,AMHCDTI
+5 SET BBD=9999999-BD
SET BED=9999999-(ED+1)
+6 SET AMHDA=0
FOR
SET AMHDA=$ORDER(^AUPNVLAB("AA",PAT,AMHDA))
IF 'AMHDA
QUIT
Begin DoDot:1
+7 SET AMHOEN=BED
FOR
SET AMHOEN=$ORDER(^AUPNVLAB("AA",PAT,AMHDA,AMHOEN))
IF 'AMHOEN!(AMHOEN>BBD)
QUIT
Begin DoDot:2
+8 SET AMHIEN=0
FOR
SET AMHIEN=$ORDER(^AUPNVLAB("AA",PAT,AMHDA,AMHOEN,AMHIEN))
IF 'AMHIEN
QUIT
Begin DoDot:3
+9 SET AMHTEST=$$GET1^DIQ(9000010.09,AMHIEN,.01)
+10 SET AMHTSTI=$$GET1^DIQ(9000010.09,AMHIEN,.01,"I")
+11 SET AMHVST=$$GET1^DIQ(9000010.09,AMHIEN,.03)
+12 SET AMHVSTI=9999999-AMHOEN
+13 SET AMHRES=$$GET1^DIQ(9000010.09,AMHIEN,.04)
+14 SET AMHABN=$$GET1^DIQ(9000010.09,AMHIEN,.05)
+15 SET AMHRL=$$GET1^DIQ(9000010.09,AMHIEN,1104)
+16 SET AMHRH=$$GET1^DIQ(9000010.09,AMHIEN,1105)
+17 SET AMHCDT=$$GET1^DIQ(9000010.09,AMHIEN,1201)
+18 SET AMHCDTI=$$GET1^DIQ(9000010.09,AMHIEN,1201,"I")
+19 SET AMHCDTI=9999999-AMHCDTI
+20 SET AMHOP=$$GET1^DIQ(9000010.09,AMHIEN,1202)
+21 IF DM="G"
Begin DoDot:4
+22 IF '$DATA(AMHRES(AMHTSTI))
SET AMHRES(AMHTSTI)=0
+23 IF $GET(AMHRES)]""
SET AMHRES(AMHTSTI)=AMHRES(AMHTSTI)+1
+24 IF '$DATA(AMHTEST("EARLY"))
SET AMHTEST("EARLY")=9999999
+25 IF '$DATA(AMHTEST("LAST"))
SET AMHTEST("LAST")=0
+26 IF AMHVSTI<AMHTEST("EARLY")
SET AMHTEST("EARLY")=AMHVSTI
+27 IF AMHVSTI>AMHTEST("LAST")
SET AMHTEST("LAST")=AMHVSTI
+28 IF '$DATA(AMHCNT(AMHTEST))
SET AMHCNT(AMHTEST)=0
+29 SET AMHCNT(AMHTEST)=AMHCNT(AMHTEST)+1
+30 SET ^TMP("AMHLABG",$JOB,AMHTEST)=AMHTSTI_U_AMHCNT(AMHTEST)_U_$GET(AMHTEST("EARLY"))_U_$GET(AMHTEST("LAST"))
End DoDot:4
QUIT
+31 IF DM="V"
Begin DoDot:4
+32 ;S ^TMP("AMHLABV",$J,AMHVST,AMHTEST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP
+33 ;v4.0p1 pr781
SET ^TMP("AMHLABV",$JOB,AMHCDTI,AMHTEST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP_U_AMHCDT
End DoDot:4
QUIT
+34 ;v4.0p1 pr781
SET ^TMP("AMHLABV",$JOB,AMHTEST,AMHVST)=AMHVST_U_AMHRES_U_AMHABN_U_AMHRL_U_AMHRH_U_AMHOP_U_AMHCDT
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
