- 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 ;
