AMHLESHF ; IHS/CMI/LAB - calls from within screenman ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
HED ;EP - display last
;DISPLAY 2 YRS WORTH OF HF 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="Health Factors List 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
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 health factors provided in past 2 years by BH programs ***" D S(X)
S X="DATE",$E(X,11)="FACTOR",$E(X,44)="SEVERITY",$E(X,57)="QUANTITY",$E(X,68)="PROVIDER" D S(X)
S X="----",$E(X,11)="------",$E(X,44)="--------",$E(X,57)="--------",$E(X,68)="--------" 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 health factors documented in PCC in past 2 years ***" D S(X)
S X="DATE",$E(X,11)="FACTOR",$E(X,44)="SEVERITY",$E(X,57)="QUANTITY",$E(X,68)="PROVIDER" D S(X,1)
S X="----",$E(X,11)="------",$E(X,44)="--------",$E(X,57)="--------",$E(X,68)="--------" D S(X)
S D=0 F S D=$O(^TMP("AMHSEDS",$J,"P",D)) Q:D'=+D D
.S I=0 F S I=$O(^TMP("AMHSEDS",$J,"P",D,I)) Q:I'=+I S X=^TMP("AMHSEDS",$J,"P",D,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(^AMHRHF("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.S R=$P(^AMHRHF(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(^AMHRHF(AMHX,0),U),T=$P(^AUTTHF(T,0),U,1),T=$E(T,1,30)
.S E=$$VAL^XBDIQ1(9002011.08,AMHX,.04)
.S P=$$VALI^XBDIQ1(9002011.08,AMHX,.05) I P S P=$P(^VA(200,P,0),U,2)
.S Q=$$VAL^XBDIQ1(9002011.08,AMHX,.06)
.S AMHC=AMHC+1
.S X=$$DATE(AMHD),$E(X,11)=T,$E(X,44)=E,$E(X,57)=Q,$E(X,68)=P S ^TMP("AMHSEDS",$J,"M",(9999999-AMHD),AMHC)=X
.S ^TMP($J,"AMHGOT",$P(^AMHRHF(AMHX,0),U),AMHD)=""
.Q
Q
GETPCCED ;
K ^TMP("AMHSEDS",$J,"P")
S AMHED=$$FMADD^XLFDT(DT,-731),AMHC=0
S AMHX=0 F S AMHX=$O(^AUPNVHF("AC",AMHPAT,AMHX)) Q:AMHX'=+AMHX D
.S R=$P(^AUPNVHF(AMHX,0),U,3) Q:'R
.S AMHD=$P($P($G(^AUPNVSIT(R,0)),U),".")
.Q:AMHD<AMHED
.S T=$P(^AUPNVHF(AMHX,0),U)
.Q:$D(^TMP($J,"AMHGOT",T,AMHD))
.S T=$P(^AUTTHF(T,0),U,1),T=$E(T,1,30)
.S E=$$VAL^XBDIQ1(9000010.23,AMHX,.04)
.S P=$$VALI^XBDIQ1(9000010.23,AMHX,.05) I P S P=$P(^VA(200,P,0),U,2)
.S Q=$$VAL^XBDIQ1(9000010.23,AMHX,.06)
.S AMHC=AMHC+1
.S X=$$DATE(AMHD),$E(X,11)=T,$E(X,44)=E,$E(X,57)=Q,$E(X,68)=P S ^TMP("AMHSEDS",$J,"P",(9999999-AMHD),AMHC)=X
.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)
;
AMHLESHF ; 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 HF 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="Health Factors List 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 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 health factors provided in past 2 years by BH programs ***"
DO S(X)
+4 SET X="DATE"
SET $EXTRACT(X,11)="FACTOR"
SET $EXTRACT(X,44)="SEVERITY"
SET $EXTRACT(X,57)="QUANTITY"
SET $EXTRACT(X,68)="PROVIDER"
DO S(X)
+5 SET X="----"
SET $EXTRACT(X,11)="------"
SET $EXTRACT(X,44)="--------"
SET $EXTRACT(X,57)="--------"
SET $EXTRACT(X,68)="--------"
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 health factors documented in PCC in past 2 years ***"
DO S(X)
+9 SET X="DATE"
SET $EXTRACT(X,11)="FACTOR"
SET $EXTRACT(X,44)="SEVERITY"
SET $EXTRACT(X,57)="QUANTITY"
SET $EXTRACT(X,68)="PROVIDER"
DO S(X,1)
+10 SET X="----"
SET $EXTRACT(X,11)="------"
SET $EXTRACT(X,44)="--------"
SET $EXTRACT(X,57)="--------"
SET $EXTRACT(X,68)="--------"
DO S(X)
+11 SET D=0
FOR
SET D=$ORDER(^TMP("AMHSEDS",$JOB,"P",D))
IF D'=+D
QUIT
Begin DoDot:1
+12 SET I=0
FOR
SET I=$ORDER(^TMP("AMHSEDS",$JOB,"P",D,I))
IF I'=+I
QUIT
SET X=^TMP("AMHSEDS",$JOB,"P",D,I)
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(^AMHRHF("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET R=$PIECE(^AMHRHF(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(^AMHRHF(AMHX,0),U)
SET T=$PIECE(^AUTTHF(T,0),U,1)
SET T=$EXTRACT(T,1,30)
+9 SET E=$$VAL^XBDIQ1(9002011.08,AMHX,.04)
+10 SET P=$$VALI^XBDIQ1(9002011.08,AMHX,.05)
IF P
SET P=$PIECE(^VA(200,P,0),U,2)
+11 SET Q=$$VAL^XBDIQ1(9002011.08,AMHX,.06)
+12 SET AMHC=AMHC+1
+13 SET X=$$DATE(AMHD)
SET $EXTRACT(X,11)=T
SET $EXTRACT(X,44)=E
SET $EXTRACT(X,57)=Q
SET $EXTRACT(X,68)=P
SET ^TMP("AMHSEDS",$JOB,"M",(9999999-AMHD),AMHC)=X
+14 SET ^TMP($JOB,"AMHGOT",$PIECE(^AMHRHF(AMHX,0),U),AMHD)=""
+15 QUIT
End DoDot:1
+16 QUIT
GETPCCED ;
+1 KILL ^TMP("AMHSEDS",$JOB,"P")
+2 SET AMHED=$$FMADD^XLFDT(DT,-731)
SET AMHC=0
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNVHF("AC",AMHPAT,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET R=$PIECE(^AUPNVHF(AMHX,0),U,3)
IF 'R
QUIT
+5 SET AMHD=$PIECE($PIECE($GET(^AUPNVSIT(R,0)),U),".")
+6 IF AMHD<AMHED
QUIT
+7 SET T=$PIECE(^AUPNVHF(AMHX,0),U)
+8 IF $DATA(^TMP($JOB,"AMHGOT",T,AMHD))
QUIT
+9 SET T=$PIECE(^AUTTHF(T,0),U,1)
SET T=$EXTRACT(T,1,30)
+10 SET E=$$VAL^XBDIQ1(9000010.23,AMHX,.04)
+11 SET P=$$VALI^XBDIQ1(9000010.23,AMHX,.05)
IF P
SET P=$PIECE(^VA(200,P,0),U,2)
+12 SET Q=$$VAL^XBDIQ1(9000010.23,AMHX,.06)
+13 SET AMHC=AMHC+1
+14 SET X=$$DATE(AMHD)
SET $EXTRACT(X,11)=T
SET $EXTRACT(X,44)=E
SET $EXTRACT(X,57)=Q
SET $EXTRACT(X,68)=P
SET ^TMP("AMHSEDS",$JOB,"P",(9999999-AMHD),AMHC)=X
+15 QUIT
End DoDot:1
+16 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 ;
