AMHLESED ; IHS/CMI/LAB - calls from within screenman ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
HED ;EP - display last
;DISPLAY 2 YRS WORTH OF PT ED 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
D HED1
NEW C S C="Patient Education List for "_$P(^DPT(AMHPAT,0),U)
D ARRAY^XBLM("^TMP(""AMHDSPEDS"",$J,",C)
K ^TMP("AMHDSPEDS",$J),^TMP($J,"AMHGOT"),^TMP("AMHSEDS",$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
K ^TMP("AMHSEDS",$J)
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 education provided in past 2 years by BH programs ***" D S(X)
S X="DATE",$E(X,11)="TOPIC",$E(X,42)="LEVEL OF UND",$E(X,58)="MIN",$E(X,62)="IND/GRP",$E(X,72)="PROVIDER" D S(X)
S X="----",$E(X,11)="-----",$E(X,42)="------------",$E(X,58)="---",$E(X,62)="-------",$E(X,72)="--------" D S(X)
S D=0 F S D=$O(^TMP("AMHSEDS",$J,"M",D)) Q:D'=+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 X=" " D S(X) S X="*** All education documented in PCC in past 2 years ***" D S(X)
S X="DATE",$E(X,11)="TOPIC",$E(X,42)="LEVEL OF UND",$E(X,58)="MIN",$E(X,62)="IND/GRP",$E(X,72)="PROVIDER" D S(X)
S X="----",$E(X,11)="-----",$E(X,42)="------------",$E(X,58)="---",$E(X,62)="-------",$E(X,72)="--------" D S(X)
S I=0 F S I=$O(^TMP("AMHSEDS",$J,"P",I)) Q:I'=+I S X=^TMP("AMHSEDS",$J,"P",I) 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(^AMHREDU("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.S R=$P(^AMHREDU(AMHX,0),U,3) Q:'R
.Q:'$$ALLOWVI^AMHUTIL(DUZ,R)
.S AMHD=$P($P($G(^AMHREC(R,0)),U),".")
.Q:AMHD<AMHED
.S T=$P(^AMHREDU(AMHX,0),U),T=$P(^AUTTEDT(T,0),U,1),T=$E(T,1,30)
.S E=$$VAL^XBDIQ1(9002011.05,AMHX,.08)
.S P=$$VALI^XBDIQ1(9002011.05,AMHX,.04) I P S P=$P(^VA(200,P,0),U,2)
.S M=$P(^AMHREDU(AMHX,0),U,6)
.S I=$$VALI^XBDIQ1(9002011.05,AMHX,.05) S:I="I" I="IND" S:I="G" I="GRP"
.S AMHC=AMHC+1
.S X=$$DATE(AMHD),$E(X,11)=$E(T,1,30),$E(X,42)=$E(E,1,15),$E(X,58)=M,$E(X,62)=I,$E(X,72)=P S ^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC)=X
.I $P($G(^AMHREDU(AMHX,11)),U,2)]"" S AMHC=AMHC+1,^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC)=" READINESS TO LEARN: "_$$VAL^XBDIQ1(9002011.05,AMHX,1102)
.I $P($G(^AMHREDU(AMHX,11)),U)]"" S AMHC=AMHC+1,^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC)=" COMMENT: "_$P(^AMHREDU(AMHX,11),U)
.S ^TMP($J,"AMHGOT",$P(^AMHREDU(AMHX,0),U),AMHD)=""
.Q
Q
GETPCCED ;
K ^TMP("AMHSEDS",$J,"P")
S AMHED=$$FMADD^XLFDT(DT,-731),AMHED=9999999-AMHED,AMHC=0
S AMHD=0 F S AMHD=$O(^AUPNVPED("AA",AMHPAT,AMHD)) Q:AMHD'=+AMHD!(AMHD>AMHED) D
.S AMHX=0 F S AMHX=$O(^AUPNVPED("AA",AMHPAT,AMHD,AMHX)) Q:AMHX'=+AMHX D
..S T=$P(^AUPNVPED(AMHX,0),U)
..Q:$D(^TMP($J,"AMHGOT",T,(9999999-AMHD))) ;already got this from BH
..S T=$P(^AUTTEDT(T,0),U,1),T=$E(T,1,30)
..S E=$$VAL^XBDIQ1(9000010.16,AMHX,.06)
..S P=$$VALI^XBDIQ1(9000010.16,AMHX,.06) I P S P=$P(^VA(200,P,0),U,2)
..S M=$P(^AUPNVPED(AMHX,0),U,8)
..S I=$$VALI^XBDIQ1(9000010.16,AMHX,.07) S:I="I" I="IND" S:I="G" I="GRP"
..S AMHC=AMHC+1
..S X=$$DATE(9999999-AMHD),$E(X,11)=$E(T,1,30),$E(X,42)=$E(E,1,15),$E(X,58)=M,$E(X,62)=I,$E(X,72)=P S ^TMP("AMHSEDS",$J,"P",AMHC)=X
..I $P($G(^AUPNVPED(AMHX,11)),U,2)]"" S AMHC=AMHC+1,^TMP("AMHSEDS",$J,"P",AMHC)=" READINESS TO LEARN: "_$$VAL^XBDIQ1(9000010.16,AMHX,1102)
..I $P($G(^AUPNVPED(AMHX,11)),U)]"" S AMHC=AMHC+1,^TMP("AMHSEDS",$J,"P",AMHC)=" COMMENT: "_$P(^AUPNVPED(AMHX,11),U)
..Q
.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("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)
;
AMHLESED ; 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 PT ED 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
+4 DO HED1
+5 NEW C
SET C="Patient Education List for "_$PIECE(^DPT(AMHPAT,0),U)
+6 DO ARRAY^XBLM("^TMP(""AMHDSPEDS"",$J,",C)
+7 KILL ^TMP("AMHDSPEDS",$JOB),^TMP($JOB,"AMHGOT"),^TMP("AMHSEDS",$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 KILL ^TMP("AMHSEDS",$JOB)
+6 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 education provided in past 2 years by BH programs ***"
DO S(X)
+4 SET X="DATE"
SET $EXTRACT(X,11)="TOPIC"
SET $EXTRACT(X,42)="LEVEL OF UND"
SET $EXTRACT(X,58)="MIN"
SET $EXTRACT(X,62)="IND/GRP"
SET $EXTRACT(X,72)="PROVIDER"
DO S(X)
+5 SET X="----"
SET $EXTRACT(X,11)="-----"
SET $EXTRACT(X,42)="------------"
SET $EXTRACT(X,58)="---"
SET $EXTRACT(X,62)="-------"
SET $EXTRACT(X,72)="--------"
DO S(X)
+6 SET D=0
FOR
SET D=$ORDER(^TMP("AMHSEDS",$JOB,"M",D))
IF D'=+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)
End DoDot:1
+8 SET X=" "
DO S(X)
SET X="*** All education documented in PCC in past 2 years ***"
DO S(X)
+9 SET X="DATE"
SET $EXTRACT(X,11)="TOPIC"
SET $EXTRACT(X,42)="LEVEL OF UND"
SET $EXTRACT(X,58)="MIN"
SET $EXTRACT(X,62)="IND/GRP"
SET $EXTRACT(X,72)="PROVIDER"
DO S(X)
+10 SET X="----"
SET $EXTRACT(X,11)="-----"
SET $EXTRACT(X,42)="------------"
SET $EXTRACT(X,58)="---"
SET $EXTRACT(X,62)="-------"
SET $EXTRACT(X,72)="--------"
DO S(X)
+11 SET I=0
FOR
SET I=$ORDER(^TMP("AMHSEDS",$JOB,"P",I))
IF I'=+I
QUIT
SET X=^TMP("AMHSEDS",$JOB,"P",I)
DO S(X)
+12 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(^AMHREDU("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET R=$PIECE(^AMHREDU(AMHX,0),U,3)
IF 'R
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,R)
QUIT
+6 SET AMHD=$PIECE($PIECE($GET(^AMHREC(R,0)),U),".")
+7 IF AMHD<AMHED
QUIT
+8 SET T=$PIECE(^AMHREDU(AMHX,0),U)
SET T=$PIECE(^AUTTEDT(T,0),U,1)
SET T=$EXTRACT(T,1,30)
+9 SET E=$$VAL^XBDIQ1(9002011.05,AMHX,.08)
+10 SET P=$$VALI^XBDIQ1(9002011.05,AMHX,.04)
IF P
SET P=$PIECE(^VA(200,P,0),U,2)
+11 SET M=$PIECE(^AMHREDU(AMHX,0),U,6)
+12 SET I=$$VALI^XBDIQ1(9002011.05,AMHX,.05)
IF I="I"
SET I="IND"
IF I="G"
SET I="GRP"
+13 SET AMHC=AMHC+1
+14 SET X=$$DATE(AMHD)
SET $EXTRACT(X,11)=$EXTRACT(T,1,30)
SET $EXTRACT(X,42)=$EXTRACT(E,1,15)
SET $EXTRACT(X,58)=M
SET $EXTRACT(X,62)=I
SET $EXTRACT(X,72)=P
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC)=X
+15 IF $PIECE($GET(^AMHREDU(AMHX,11)),U,2)]""
SET AMHC=AMHC+1
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC)=" READINESS TO LEARN: "_$$VAL^XBDIQ1(9002011.05,AMHX,1102)
+16 IF $PIECE($GET(^AMHREDU(AMHX,11)),U)]""
SET AMHC=AMHC+1
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC)=" COMMENT: "_$PIECE(^AMHREDU(AMHX,11),U)
+17 SET ^TMP($JOB,"AMHGOT",$PIECE(^AMHREDU(AMHX,0),U),AMHD)=""
+18 QUIT
End DoDot:1
+19 QUIT
GETPCCED ;
+1 KILL ^TMP("AMHSEDS",$JOB,"P")
+2 SET AMHED=$$FMADD^XLFDT(DT,-731)
SET AMHED=9999999-AMHED
SET AMHC=0
+3 SET AMHD=0
FOR
SET AMHD=$ORDER(^AUPNVPED("AA",AMHPAT,AMHD))
IF AMHD'=+AMHD!(AMHD>AMHED)
QUIT
Begin DoDot:1
+4 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVPED("AA",AMHPAT,AMHD,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+5 SET T=$PIECE(^AUPNVPED(AMHX,0),U)
+6 ;already got this from BH
IF $DATA(^TMP($JOB,"AMHGOT",T,(9999999-AMHD)))
QUIT
+7 SET T=$PIECE(^AUTTEDT(T,0),U,1)
SET T=$EXTRACT(T,1,30)
+8 SET E=$$VAL^XBDIQ1(9000010.16,AMHX,.06)
+9 SET P=$$VALI^XBDIQ1(9000010.16,AMHX,.06)
IF P
SET P=$PIECE(^VA(200,P,0),U,2)
+10 SET M=$PIECE(^AUPNVPED(AMHX,0),U,8)
+11 SET I=$$VALI^XBDIQ1(9000010.16,AMHX,.07)
IF I="I"
SET I="IND"
IF I="G"
SET I="GRP"
+12 SET AMHC=AMHC+1
+13 SET X=$$DATE(9999999-AMHD)
SET $EXTRACT(X,11)=$EXTRACT(T,1,30)
SET $EXTRACT(X,42)=$EXTRACT(E,1,15)
SET $EXTRACT(X,58)=M
SET $EXTRACT(X,62)=I
SET $EXTRACT(X,72)=P
SET ^TMP("AMHSEDS",$JOB,"P",AMHC)=X
+14 IF $PIECE($GET(^AUPNVPED(AMHX,11)),U,2)]""
SET AMHC=AMHC+1
SET ^TMP("AMHSEDS",$JOB,"P",AMHC)=" READINESS TO LEARN: "_$$VAL^XBDIQ1(9000010.16,AMHX,1102)
+15 IF $PIECE($GET(^AUPNVPED(AMHX,11)),U)]""
SET AMHC=AMHC+1
SET ^TMP("AMHSEDS",$JOB,"P",AMHC)=" COMMENT: "_$PIECE(^AUPNVPED(AMHX,11),U)
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 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 ;
