Routine: AMHLESED

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

HED1 ;EP

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

 D GETMHED

 D GETPCCED

 D SETARRAY

 K ^TMP("AMHSEDS",$J)

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)

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

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

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

S1 ;

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

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

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       ;

AMHLESED.m