AMHLESEA ; IHS/CMI/LAB - calls from within screenman ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
HED ;EP - display last
;DISPLAY 2 YRS WORTH OF EXAMS FROM MHSS/PCC
I '$G(AMHPAT) S AMHMSG(1)="Unknown Patient" D HLP^DDSUTL(.AMHMSG) K AMHMSG Q
NEW AMHX,AMHD,AMHC,AMHED,X,Y,R,AMHE
D HED1
NEW C S C="Alcohol Screening Exam History for "_$P(^DPT(AMHPAT,0),U)
D ARRAY^XBLM("^TMP(""AMHDSPEDS"",$J,",C)
K ^TMP("AMHDSPEDS",$J),^TMP($J,"AMHGOT"),^TMP("AMHEDS",$J)
REFRESH ;
S X=0 X ^%ZOSF("RM")
W $P(DDGLVID,DDGLDEL,8)
D REFRESH^DDSUTL
Q
HED1 ;EP
S %=$$FMADD^XLFDT(DT,-731),%1=""
D GETMHED
D GETPCCED
D SETARRAY
Q
SETARRAY ;
K ^TMP("AMHDSPEDS",$J) S ^TMP("AMHDSPEDS",$J,0)=0
S X=" " D S(X)
S X=" " D S(X) S X="*** All Alcohol Screening Exams documented in BH ***" D S(X)
S X="DATE",$E(X,11)="SCREENING RESULT",$E(X,44)="PROVIDER" D S(X)
S X="----",$E(X,11)="----------------",$E(X,44)="--------" D S(X)
S D=0 F S D=$O(^TMP("AMHSEDS",$J,"M",D)) Q:D="" D
.S I=0 F S I=$O(^TMP("AMHSEDS",$J,"M",D,I)) Q:I'=+I S X=^TMP("AMHSEDS",$J,"M",D,I) D S(X) S R=$G(^TMP("AMHSEDS",$J,"M",D,I,1)) I R]"" S X="",$E(X,11)=R D S(X)
S X=" " D S(X) S X="*** All Alcohol Screening Exams document in PCC ***" D S(X)
S X="DATE",$E(X,11)="SCREENING RESULT",$E(X,44)="PROVIDER" D S(X)
S X="----",$E(X,11)="----------------",$E(X,44)="--------" D S(X)
S AMHD=0 F S AMHD=$O(^TMP("AMHSEDS",$J,"P",AMHD)) Q:AMHD'=+AMHD D
.S I=0 F S I=$O(^TMP("AMHSEDS",$J,"P",AMHD,I)) Q:I'=+I S X=^TMP("AMHSEDS",$J,"P",AMHD,I) D S(X) S R=$G(^TMP("AMHSEDS",$J,"P",AMHD,I,1)) I R]"" S X="",$E(X,11)=R D S(X)
Q
GETMHED ;set array ^TMP("AMHSEDS",$J,"M" OF EDS IN MH FILE
K ^TMP("AMHSEDS",$J,"M"),^TMP($J,"AMHGOT")
S AMHED=$$FMADD^XLFDT(DT,-731),AMHC=0
S AMHX=0 F S AMHX=$O(^AMHREC("C",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHX)
.S R=$P($G(^AMHREC(AMHX,14)),U,3)
.Q:R=""
.S AMHD=$P($P($G(^AMHREC(AMHX,0)),U),".")
.S C=$$VAL^XBDIQ1(9002011,AMHX,1601)
.S P=$$VAL^XBDIQ1(9002011,AMHX,1404)
.S R=$$VAL^XBDIQ1(9002011,AMHX,1403)
.S AMHC=AMHC+1
.S X=$$DATE(AMHD),$E(X,11)=R,$E(X,44)=P S ^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC)=X I C]"" S ^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC,1)=C
.S ^TMP($J,"AMHGOT",AMHD)=""
.Q
Q
GETPCCED ;
K ^TMP("AMHSEDS",$J,"P")
S AMHE=$O(^AUTTEXAM("C",35,0))
S AMHED=$$FMADD^XLFDT(DT,-731),AMHC=0
S AMHX=0 F S AMHX=$O(^AUPNVXAM("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.S R=$P($G(^AUPNVXAM(AMHX,0)),U) I R'=AMHE Q ;not ipv
.S R=$P(^AUPNVXAM(AMHX,0),U,3) Q:'R
.S AMHD=$P($P($G(^AUPNVSIT(R,0)),U),".")
.;Q:AMHD<AMHED
.Q:$D(^TMP($J,"AMHGOT",AMHD))
.S R=$$VAL^XBDIQ1(9000010.13,AMHX,.04) S:R["NEGATIVE" R="NEGATIVE" S:R="" R="NO RESULT DOCUMENTED"
.S C=$$VAL^XBDIQ1(9000010.13,AMHX,81101)
.S P=$$VAL^XBDIQ1(9000010.13,AMHX,1204)
.S AMHC=AMHC+1
.S X=$$DATE(AMHD),$E(X,11)=R,$E(X,44)=P S ^TMP("AMHSEDS",$J,"P",(9999999-AMHD),AMHC)=X I C]"" S ^TMP("AMHSEDS",$J,"P",(9999999-AMHD),AMHC,1)=C
.Q
;now get refusals
S AMHD=0 F S AMHD=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHE,AMHD)) Q:AMHD'=+AMHD D
.S AMHX=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHE,AMHD,AMHX)) Q:AMHX'=+AMHX D
..Q:$D(^TMP($J,"AMHGOT",(9999999-AMHD)))
..S R=$$VAL^XBDIQ1(9000022,AMHX,.07) S:R["REFUSED" R="REFUSED SCREENING" S:R["NEGATIVE" R="NEGATIVE" S:R="" R="NO RESULT DOCUMENTED"
..S P=$$VAL^XBDIQ1(9000022,AMHX,1204)
..S X=$$DATE((9999999-AMHD)),$E(X,11)=R,$E(X,44)=P S ^TMP("AMHSEDS",$J,"P",AMHD,AMHC)=X I C]"" S ^TMP("AMHSEDS",$J,"P",AMHD,AMHC,1)=C
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("AMHDSPEDS",$J,0),U)+1,$P(^TMP("AMHDSPEDS",$J,0),U)=%
S ^TMP("AMHDSPEDS",$J,%,0)=X
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
AMHLESEA ; IHS/CMI/LAB - calls from within screenman ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
HED ;EP - display last
+1 ;DISPLAY 2 YRS WORTH OF EXAMS FROM MHSS/PCC
+2 IF '$GET(AMHPAT)
SET AMHMSG(1)="Unknown Patient"
DO HLP^DDSUTL(.AMHMSG)
KILL AMHMSG
QUIT
+3 NEW AMHX,AMHD,AMHC,AMHED,X,Y,R,AMHE
+4 DO HED1
+5 NEW C
SET C="Alcohol Screening Exam History for "_$PIECE(^DPT(AMHPAT,0),U)
+6 DO ARRAY^XBLM("^TMP(""AMHDSPEDS"",$J,",C)
+7 KILL ^TMP("AMHDSPEDS",$JOB),^TMP($JOB,"AMHGOT"),^TMP("AMHEDS",$JOB)
REFRESH ;
+1 SET X=0
XECUTE ^%ZOSF("RM")
+2 WRITE $PIECE(DDGLVID,DDGLDEL,8)
+3 DO REFRESH^DDSUTL
+4 QUIT
HED1 ;EP
+1 SET %=$$FMADD^XLFDT(DT,-731)
SET %1=""
+2 DO GETMHED
+3 DO GETPCCED
+4 DO SETARRAY
+5 QUIT
SETARRAY ;
+1 KILL ^TMP("AMHDSPEDS",$JOB)
SET ^TMP("AMHDSPEDS",$JOB,0)=0
+2 SET X=" "
DO S(X)
+3 SET X=" "
DO S(X)
SET X="*** All Alcohol Screening Exams documented in BH ***"
DO S(X)
+4 SET X="DATE"
SET $EXTRACT(X,11)="SCREENING RESULT"
SET $EXTRACT(X,44)="PROVIDER"
DO S(X)
+5 SET X="----"
SET $EXTRACT(X,11)="----------------"
SET $EXTRACT(X,44)="--------"
DO S(X)
+6 SET D=0
FOR
SET D=$ORDER(^TMP("AMHSEDS",$JOB,"M",D))
IF D=""
QUIT
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(^TMP("AMHSEDS",$JOB,"M",D,I))
IF I'=+I
QUIT
SET X=^TMP("AMHSEDS",$JOB,"M",D,I)
DO S(X)
SET R=$GET(^TMP("AMHSEDS",$JOB,"M",D,I,1))
IF R]""
SET X=""
SET $EXTRACT(X,11)=R
DO S(X)
End DoDot:1
+8 SET X=" "
DO S(X)
SET X="*** All Alcohol Screening Exams document in PCC ***"
DO S(X)
+9 SET X="DATE"
SET $EXTRACT(X,11)="SCREENING RESULT"
SET $EXTRACT(X,44)="PROVIDER"
DO S(X)
+10 SET X="----"
SET $EXTRACT(X,11)="----------------"
SET $EXTRACT(X,44)="--------"
DO S(X)
+11 SET AMHD=0
FOR
SET AMHD=$ORDER(^TMP("AMHSEDS",$JOB,"P",AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^TMP("AMHSEDS",$JOB,"P",AMHD,I))
IF I'=+I
QUIT
SET X=^TMP("AMHSEDS",$JOB,"P",AMHD,I)
DO S(X)
SET R=$GET(^TMP("AMHSEDS",$JOB,"P",AMHD,I,1))
IF R]""
SET X=""
SET $EXTRACT(X,11)=R
DO S(X)
End DoDot:1
+13 QUIT
GETMHED ;set array ^TMP("AMHSEDS",$J,"M" OF EDS IN MH FILE
+1 KILL ^TMP("AMHSEDS",$JOB,"M"),^TMP($JOB,"AMHGOT")
+2 SET AMHED=$$FMADD^XLFDT(DT,-731)
SET AMHC=0
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC("C",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHX)
QUIT
+5 SET R=$PIECE($GET(^AMHREC(AMHX,14)),U,3)
+6 IF R=""
QUIT
+7 SET AMHD=$PIECE($PIECE($GET(^AMHREC(AMHX,0)),U),".")
+8 SET C=$$VAL^XBDIQ1(9002011,AMHX,1601)
+9 SET P=$$VAL^XBDIQ1(9002011,AMHX,1404)
+10 SET R=$$VAL^XBDIQ1(9002011,AMHX,1403)
+11 SET AMHC=AMHC+1
+12 SET X=$$DATE(AMHD)
SET $EXTRACT(X,11)=R
SET $EXTRACT(X,44)=P
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC)=X
IF C]""
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC,1)=C
+13 SET ^TMP($JOB,"AMHGOT",AMHD)=""
+14 QUIT
End DoDot:1
+15 QUIT
GETPCCED ;
+1 KILL ^TMP("AMHSEDS",$JOB,"P")
+2 SET AMHE=$ORDER(^AUTTEXAM("C",35,0))
+3 SET AMHED=$$FMADD^XLFDT(DT,-731)
SET AMHC=0
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVXAM("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+5 ;not ipv
SET R=$PIECE($GET(^AUPNVXAM(AMHX,0)),U)
IF R'=AMHE
QUIT
+6 SET R=$PIECE(^AUPNVXAM(AMHX,0),U,3)
IF 'R
QUIT
+7 SET AMHD=$PIECE($PIECE($GET(^AUPNVSIT(R,0)),U),".")
+8 ;Q:AMHD<AMHED
+9 IF $DATA(^TMP($JOB,"AMHGOT",AMHD))
QUIT
+10 SET R=$$VAL^XBDIQ1(9000010.13,AMHX,.04)
IF R["NEGATIVE"
SET R="NEGATIVE"
IF R=""
SET R="NO RESULT DOCUMENTED"
+11 SET C=$$VAL^XBDIQ1(9000010.13,AMHX,81101)
+12 SET P=$$VAL^XBDIQ1(9000010.13,AMHX,1204)
+13 SET AMHC=AMHC+1
+14 SET X=$$DATE(AMHD)
SET $EXTRACT(X,11)=R
SET $EXTRACT(X,44)=P
SET ^TMP("AMHSEDS",$JOB,"P",(9999999-AMHD),AMHC)=X
IF C]""
SET ^TMP("AMHSEDS",$JOB,"P",(9999999-AMHD),AMHC,1)=C
+15 QUIT
End DoDot:1
+16 ;now get refusals
+17 SET AMHD=0
FOR
SET AMHD=$ORDER(^AUPNPREF("AA",AMHPAT,9999999.15,AMHE,AMHD))
IF AMHD'=+AMHD
QUIT
Begin DoDot:1
+18 SET AMHX=$ORDER(^AUPNPREF("AA",AMHPAT,9999999.15,AMHE,AMHD,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+19 IF $DATA(^TMP($JOB,"AMHGOT",(9999999-AMHD)))
QUIT
+20 SET R=$$VAL^XBDIQ1(9000022,AMHX,.07)
IF R["REFUSED"
SET R="REFUSED SCREENING"
IF R["NEGATIVE"
SET R="NEGATIVE"
IF R=""
SET R="NO RESULT DOCUMENTED"
+21 SET P=$$VAL^XBDIQ1(9000022,AMHX,1204)
+22 SET X=$$DATE((9999999-AMHD))
SET $EXTRACT(X,11)=R
SET $EXTRACT(X,44)=P
SET ^TMP("AMHSEDS",$JOB,"P",AMHD,AMHC)=X
IF C]""
SET ^TMP("AMHSEDS",$JOB,"P",AMHD,AMHC,1)=C
End DoDot:2
End DoDot:1
+23 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("AMHDSPEDS",$JOB,0),U)+1
SET $PIECE(^TMP("AMHDSPEDS",$JOB,0),U)=%
+2 SET ^TMP("AMHDSPEDS",$JOB,%,0)=X
+3 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
