Routine: BHSEYEKG

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

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,!!

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

 ; <CLEANUP>

EYERXX K BHSDAT,BHSDT,BHSEN,BHSF,BHSI,BHSJ,BHSL,BHSL1,BHSL2,BHSN,BHST,BHSVDF,Y,BHSM,BHSVNM,BHSMT,BHSM,BHSJ,BHSX

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)

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)

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

BLDL S BHSF=$J($P(BHSEN,U,BHSI),8)

 S BHSL=BHSL_BHSF

NPG W BHSDAT,?10,BHSNSH,!

 W "  Sphere     Cyl    Axis  Prism H   Prism V   Add",!

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

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,!

GETEKG ;get EKG

 S BHSDP=$P(^AUTTDXPR(BHSDP,0),U)

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

BHSEYEKG.m