BHSEYEKG ;IHS/CIA/MGH - Health Summary eye and EKG components ;05-Oct-2012 09:30;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**7**;March 17, 2006;Build 12
;===================================================================
;VA version of IHS health summary components for eye glasses and EKGs
EYERX ; *************** EYE GLASS PRESCRIPTIONS * 9000010.04 *******
; <SETUP>
N BHSPAT,BHSP,BHSNSH,X
S BHSPAT=DFN
D EYEMEAS
Q:'$D(^AUPNVEYE("AA",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSDT=$O(^AUPNVEYE("AA",BHSPAT,0)) Q:BHSDT="" D
.W !!?29,"Current Eyeglass Prescription"
.S BHSN="" F S BHSN=$O(^AUPNVEYE("AA",BHSPAT,BHSDT,BHSN)) Q:BHSN="" D
..S BHSP=^AUPNVEYE(BHSN,0),BHSVDF=$P(BHSP,U,3) D GETSITEV^BHSUTL
..S X=-BHSDT\1+9999999 D REGDT4^GMTSU S BHSDAT=X
..D BLD
D EYERXX
Q
BLD ; <BUILD>
S BHSEN=$G(^AUPNVEYE(BHSN,19))
S BHST="Reading only^^^^^^^^^^^^Pupil near^Pupil far^^^^^Pupil L^Pupil R"
S BHSJ="1^^^^^^^^^2^2^4^2^2^^^^2^2"
S BHSL="" F BHSI=1,13 D ADDTOL
S BHSL1=$E(BHSL,3,255)
S BHSL="" F BHSI=14,19,20 D ADDTOL
S BHSL2=$E(BHSL,3,255)
S BHST=""
S BHSL="R" F BHSI=2,3,4,15,17,8 D BLDL
DSPLY ;<DISPLAY>
D CKP^GMTSUP Q:$D(GMTSQIT) W !,BHSDAT,?12,BHSNSH,!
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG !,BHSDAT,?10,BHSNSH,!
W " Sphere Cyl Axis Prism H Prism V Add",!
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG NPG W !,BHSL,!
S BHSL="L" F BHSI=5,6,7,16,18,9 D BLDL
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG NPG W BHSL,!
S BHSL1=BHSL1_" "_BHSL2
D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG NPG W !,BHSL1,!!
Q
EYEMEAS ;display eye care measurements
K BHSMT
S BHSM=$O(^AUTTMSR("C","07",0)),BHSP=1 I BHSM D GATHER
S BHSM=$O(^AUTTMSR("C","08",0)),BHSP=2 I BHSM D GATHER
S BHSM=$O(^AUTTMSR("C","11",0)),BHSP=3 I BHSM D GATHER
D DISPEM
Q
; <CLEANUP>
EYERXX K BHSDAT,BHSDT,BHSEN,BHSF,BHSI,BHSJ,BHSL,BHSL1,BHSL2,BHSN,BHST,BHSVDF,Y,BHSM,BHSVNM,BHSMT,BHSM,BHSJ,BHSX
Q
GATHER ;gather up last 5 of measurement in array by inverse date
N C,D,N
S (C,D,N)=0 F S D=$O(^AUPNVMSR("AA",BHSPAT,BHSM,D)) Q:D'=+D S N=0 F S N=$O(^AUPNVMSR("AA",BHSPAT,BHSM,D,N)) Q:N'=+N!(C>3) S C=C+1,$P(BHSMT(D),U,BHSP)=$$VAL^XBDIQ1(9000010.01,N,.04)
Q
DISPEM ;display eye measurements
D CKP^GMTSUP Q:$D(GMTSQIT)
W !?29,"Eye Care Measurements"
D CKP^GMTSUP Q:$D(GMTSQIT)
W !?15,"VU",?34,"VC",?48,"TONOMETRY"
S BHSX=0 F S BHSX=$O(BHSMT(BHSX)) Q:BHSX=""!($D(GMTSQIT)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,$$FMTE^XLFDT((9999999-BHSX),"2D") S BHSJ="10;29;48" F BHST=1:1:3 W ?$P(BHSJ,";",BHST),$P(BHSMT(BHSX),U,BHST)
Q
ADDTOL S BHSF=$P(BHSEN,U,BHSI) S:BHSF="" BHSF="-" S BHSF=$J(BHSF,$P(BHSJ,U,BHSI))
S:BHSF]"" BHSL=BHSL_" "_$P(BHST,U,BHSI)_": "_BHSF
Q
BLDL S BHSF=$J($P(BHSEN,U,BHSI),8)
S BHSL=BHSL_BHSF
Q
NPG W BHSDAT,?10,BHSNSH,!
W " Sphere Cyl Axis Prism H Prism V Add",!
Q
;
;
EKG ; ***** EKG SUMMARY * 9000010.21 (V DIAGNOSTIC PROCEDURE RESULT) *****
;<setup>
N BHSPAT,APCHQ,BHSQ
S BHSPAT=DFN
Q:'$D(^AUPNVDXP("AC",BHSPAT))
D CKP^GMTSUP Q:$D(GMTSQIT)
S BHSCNT=0
S BHSDAT=0 F BHSQ=0:0 S BHSDAT=$O(^AUPNVDXP("AA",BHSPAT,BHSDAT)) Q:'BHSDAT D Q:$D(GMTSQIT)
. S BHSIVD=0 F APCHQ=0:0 S BHSIVD=$O(^AUPNVDXP("AA",BHSPAT,BHSDAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D Q:$D(GMTSQIT)
.. S BHSDFN=0 F APCHQ=0:0 S BHSDFN=$O(^AUPNVDXP("AA",BHSPAT,BHSDAT,BHSIVD,BHSDFN)) Q:'BHSDFN D EKGDSP Q:$D(GMTSQIT)
.. Q
. Q
;
EKGX ; exit EKG
;<CLEANUP>
K BHSDP,BHSDFN,BHSNRQ,BHSDAT,BHSDS,BHSN,BHSIVD,BHSVL,BHSCNT,Y
Q
;
EKGDSP ;display EKG(S)
; <DISPLAY>
S BHSN=^AUPNVDXP(BHSDFN,0)
S BHSDP=$P(BHSN,U,1)
D GETEKG Q:BHSDP=""
S BHSCNT=BHSCNT+1
S BHSDS="DATE?"
S Y=$P(BHSN,U,3),X=+^AUPNVSIT(Y,0)\1 D REGDT4^GMTSU S BHSDS=X
S BHSVL=$P($P(BHSN,U,4),":")
S BHSVL=$S(BHSVL="N":"NORMAL",BHSVL="A":"ABNORMAL",BHSVL="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline
D CKP^GMTSUP Q:$D(GMTSQIT)
W BHSDS W ?12,BHSDP,?30,"RESULT: ",BHSVL,!
Q
GETEKG ;get EKG
S BHSDP=$P(^AUTTDXPR(BHSDP,0),U)
Q
BHSEYEKG ;IHS/CIA/MGH - Health Summary eye and EKG components ;05-Oct-2012 09:30;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**7**;March 17, 2006;Build 12
+2 ;===================================================================
+3 ;VA version of IHS health summary components for eye glasses and EKGs
EYERX ; *************** EYE GLASS PRESCRIPTIONS * 9000010.04 *******
+1 ; <SETUP>
+2 NEW BHSPAT,BHSP,BHSNSH,X
+3 SET BHSPAT=DFN
+4 DO EYEMEAS
+5 IF '$DATA(^AUPNVEYE("AA",BHSPAT))
QUIT
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 SET BHSDT=$ORDER(^AUPNVEYE("AA",BHSPAT,0))
IF BHSDT=""
QUIT
Begin DoDot:1
+8 WRITE !!?29,"Current Eyeglass Prescription"
+9 SET BHSN=""
FOR
SET BHSN=$ORDER(^AUPNVEYE("AA",BHSPAT,BHSDT,BHSN))
IF BHSN=""
QUIT
Begin DoDot:2
+10 SET BHSP=^AUPNVEYE(BHSN,0)
SET BHSVDF=$PIECE(BHSP,U,3)
DO GETSITEV^BHSUTL
+11 SET X=-BHSDT\1+9999999
DO REGDT4^GMTSU
SET BHSDAT=X
+12 DO BLD
End DoDot:2
End DoDot:1
+13 DO EYERXX
+14 QUIT
BLD ; <BUILD>
+1 SET BHSEN=$GET(^AUPNVEYE(BHSN,19))
+2 SET BHST="Reading only^^^^^^^^^^^^Pupil near^Pupil far^^^^^Pupil L^Pupil R"
+3 SET BHSJ="1^^^^^^^^^2^2^4^2^2^^^^2^2"
+4 SET BHSL=""
FOR BHSI=1,13
DO ADDTOL
+5 SET BHSL1=$EXTRACT(BHSL,3,255)
+6 SET BHSL=""
FOR BHSI=14,19,20
DO ADDTOL
+7 SET BHSL2=$EXTRACT(BHSL,3,255)
+8 SET BHST=""
+9 SET BHSL="R"
FOR BHSI=2,3,4,15,17,8
DO BLDL
DSPLY ;<DISPLAY>
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,BHSDAT,?12,BHSNSH,!
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE !,BHSDAT,?10,BHSNSH,!
+3 WRITE " Sphere Cyl Axis Prism H Prism V Add",!
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO NPG
WRITE !,BHSL,!
+5 SET BHSL="L"
FOR BHSI=5,6,7,16,18,9
DO BLDL
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO NPG
WRITE BHSL,!
+7 SET BHSL1=BHSL1_" "_BHSL2
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
DO NPG
WRITE !,BHSL1,!!
+9 QUIT
EYEMEAS ;display eye care measurements
+1 KILL BHSMT
+2 SET BHSM=$ORDER(^AUTTMSR("C","07",0))
SET BHSP=1
IF BHSM
DO GATHER
+3 SET BHSM=$ORDER(^AUTTMSR("C","08",0))
SET BHSP=2
IF BHSM
DO GATHER
+4 SET BHSM=$ORDER(^AUTTMSR("C","11",0))
SET BHSP=3
IF BHSM
DO GATHER
+5 DO DISPEM
+6 QUIT
+7 ; <CLEANUP>
EYERXX KILL BHSDAT,BHSDT,BHSEN,BHSF,BHSI,BHSJ,BHSL,BHSL1,BHSL2,BHSN,BHST,BHSVDF,Y,BHSM,BHSVNM,BHSMT,BHSM,BHSJ,BHSX
+1 QUIT
GATHER ;gather up last 5 of measurement in array by inverse date
+1 NEW C,D,N
+2 SET (C,D,N)=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSM,D))
IF D'=+D
QUIT
SET N=0
FOR
SET N=$ORDER(^AUPNVMSR("AA",BHSPAT,BHSM,D,N))
IF N'=+N!(C>3)
QUIT
SET C=C+1
SET $PIECE(BHSMT(D),U,BHSP)=$$VAL^XBDIQ1(9000010.01,N,.04)
+3 QUIT
DISPEM ;display eye measurements
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+2 WRITE !?29,"Eye Care Measurements"
+3 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+4 WRITE !?15,"VU",?34,"VC",?48,"TONOMETRY"
+5 SET BHSX=0
FOR
SET BHSX=$ORDER(BHSMT(BHSX))
IF BHSX=""!($DATA(GMTSQIT))
QUIT
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,$$FMTE^XLFDT((9999999-BHSX),"2D")
SET BHSJ="10;29;48"
FOR BHST=1:1:3
WRITE ?$PIECE(BHSJ,";",BHST),$PIECE(BHSMT(BHSX),U,BHST)
+6 QUIT
ADDTOL SET BHSF=$PIECE(BHSEN,U,BHSI)
IF BHSF=""
SET BHSF="-"
SET BHSF=$JUSTIFY(BHSF,$PIECE(BHSJ,U,BHSI))
+1 IF BHSF]""
SET BHSL=BHSL_" "_$PIECE(BHST,U,BHSI)_": "_BHSF
+2 QUIT
BLDL SET BHSF=$JUSTIFY($PIECE(BHSEN,U,BHSI),8)
+1 SET BHSL=BHSL_BHSF
+2 QUIT
NPG WRITE BHSDAT,?10,BHSNSH,!
+1 WRITE " Sphere Cyl Axis Prism H Prism V Add",!
+2 QUIT
+3 ;
+4 ;
EKG ; ***** EKG SUMMARY * 9000010.21 (V DIAGNOSTIC PROCEDURE RESULT) *****
+1 ;<setup>
+2 NEW BHSPAT,APCHQ,BHSQ
+3 SET BHSPAT=DFN
+4 IF '$DATA(^AUPNVDXP("AC",BHSPAT))
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 SET BHSCNT=0
+7 SET BHSDAT=0
FOR BHSQ=0:0
SET BHSDAT=$ORDER(^AUPNVDXP("AA",BHSPAT,BHSDAT))
IF 'BHSDAT
QUIT
Begin DoDot:1
+8 SET BHSIVD=0
FOR APCHQ=0:0
SET BHSIVD=$ORDER(^AUPNVDXP("AA",BHSPAT,BHSDAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:2
+9 SET BHSDFN=0
FOR APCHQ=0:0
SET BHSDFN=$ORDER(^AUPNVDXP("AA",BHSPAT,BHSDAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
DO EKGDSP
IF $DATA(GMTSQIT)
QUIT
+10 QUIT
End DoDot:2
IF $DATA(GMTSQIT)
QUIT
+11 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+12 ;
EKGX ; exit EKG
+1 ;<CLEANUP>
+2 KILL BHSDP,BHSDFN,BHSNRQ,BHSDAT,BHSDS,BHSN,BHSIVD,BHSVL,BHSCNT,Y
+3 QUIT
+4 ;
EKGDSP ;display EKG(S)
+1 ; <DISPLAY>
+2 SET BHSN=^AUPNVDXP(BHSDFN,0)
+3 SET BHSDP=$PIECE(BHSN,U,1)
+4 DO GETEKG
IF BHSDP=""
QUIT
+5 SET BHSCNT=BHSCNT+1
+6 SET BHSDS="DATE?"
+7 SET Y=$PIECE(BHSN,U,3)
SET X=+^AUPNVSIT(Y,0)\1
DO REGDT4^GMTSU
SET BHSDS=X
+8 SET BHSVL=$PIECE($PIECE(BHSN,U,4),":")
+9 ;IHS/CMI/LAB added borderline
SET BHSVL=$SELECT(BHSVL="N":"NORMAL",BHSVL="A":"ABNORMAL",BHSVL="B":"BORDERLINE",1:"<none recorded>")
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 WRITE BHSDS
WRITE ?12,BHSDP,?30,"RESULT: ",BHSVL,!
+12 QUIT
GETEKG ;get EKG
+1 SET BHSDP=$PIECE(^AUTTDXPR(BHSDP,0),U)
+2 QUIT
