AMHLESEA.m

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       ;