APCHS8A ; IHS/CMI/LAB - PART 8A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
;
EYERX ; *************** EYE GLASS PRESCRIPTIONS * 9000010.04 *******
; <SETUP>
Q:'$D(^AUPNVEYE("AA",APCHSPAT))
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S APCHSDT=$O(^AUPNVEYE("AA",APCHSPAT,0))
S APCHSN=$O(^AUPNVEYE("AA",APCHSPAT,APCHSDT,0))
S APCHSP=^AUPNVEYE(APCHSN,0),APCHSVDF=$P(APCHSP,U,3) D GETSITEV^APCHSUTL
S Y=-APCHSDT\1+9999999 X APCHSCVD S APCHSDAT=Y
BLD ; <BUILD>
S APCHSEN=$G(^AUPNVEYE(APCHSN,19))
S APCHST="Reading only^^^^^^^^^^^^Pupil near^Pupil far"
S APCHSJ="1^^^^^^^^^2^2^4^2^2"
S APCHSL="" F APCHSI=1,13 D ADDTOL
S APCHSL1=$E(APCHSL,3,255)
S APCHSL="" F APCHSI=14 D ADDTOL
S APCHSL2=$E(APCHSL,3,255)
S APCHST=""
S APCHSL="R" F APCHSI=2,3,4,15,8 D BLDL
DSPLY ;<DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) W APCHSDAT,?10,APCHSNSH,!
X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG APCHSDAT,?10,APCHSNSH,!
W " Sphere Cyl Axis Prism Add",!
X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG NPG W APCHSL,?44,APCHSL1,!
S APCHSL="L" F APCHSI=5,6,7,16,9 D BLDL
X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG NPG W APCHSL,?61,APCHSL2,!
EYEMEAS ;display eye care measurements
K APCHSMT
S APCHSM=$O(^AUTTMSR("C","07",0)),APCHSP=1 I APCHSM D GATHER
S APCHSM=$O(^AUTTMSR("C","08",0)),APCHSP=2 I APCHSM D GATHER
S APCHSM=$O(^AUTTMSR("C","11",0)),APCHSP=3 I APCHSM D GATHER
D DISPEM
; <CLEANUP>
EYERXX K APCHSDAT,APCHSDT,APCHSEN,APCHSF,APCHSI,APCHSJ,APCHSL,APCHSL1,APCHSL2,APCHSN,APCHST,APCHSVDF,Y,APCHSM,APCHSVNM,APCHSMT,APCHSM,APCHSJ,APCHSX
Q
GATHER ;gather up last 5 of measurement in array by inverse date
S (C,D,N)=0 F S D=$O(^AUPNVMSR("AA",APCHSPAT,APCHSM,D)) Q:D'=+D S N=0 F S N=$O(^AUPNVMSR("AA",APCHSPAT,APCHSM,D,N)) Q:N'=+N!(C>3) D
.Q:$P($G(^AUPNVMSR(N,2)),U,1)
.S C=C+1,$P(APCHSMT(D),U,APCHSP)=$$VAL^XBDIQ1(9000010.01,N,.04)
Q
DISPEM ;display eye measurements
X APCHSCKP Q:$D(APCHSQIT)
W !?29,"Eye Care Measurements"
X APCHSCKP Q:$D(APCHSQIT)
W !?15,"VU",?34,"VC",?48,"TONOMETRY"
S APCHSX=0 F S APCHSX=$O(APCHSMT(APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) X APCHSCKP Q:$D(APCHSQIT) W !,$$FMTE^XLFDT((9999999-APCHSX),"2D") S APCHSJ="10;29;48" F APCHST=1:1:3 W ?$P(APCHSJ,";",APCHST),$P(APCHSMT(APCHSX),U,APCHST)
Q
ADDTOL S APCHSF=$P(APCHSEN,U,APCHSI) S:APCHSF="" APCHSF="-" S APCHSF=$J(APCHSF,$P(APCHSJ,U,APCHSI))
S:APCHSF]"" APCHSL=APCHSL_" "_$P(APCHST,U,APCHSI)_": "_APCHSF
Q
BLDL S APCHSF=$J($P(APCHSEN,U,APCHSI),7)
S APCHSL=APCHSL_APCHSF
Q
NPG W APCHSDAT,?10,APCHSNSH,!
W " Sphere Cyl Axis Prism Add",!
Q
;
;
EKG ; ***** EKG SUMMARY * 9000010.21 (V DIAGNOSTIC PROCEDURE RESULT) *****
;<setup>
;Q:'$D(^AUPNVDXP("AC",APCHSPAT))
I '$D(^AUPNVDXP("AC",APCHSPAT)),'$D(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002)) Q
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
S APCHSCNT=0
S APCHSDAT=0 F APCHSQ=0:0 S APCHSDAT=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT)) Q:'APCHSDAT D Q:$D(APCHSQIT)
. S APCHSIVD=0 F APCHQ=0:0 S APCHSIVD=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D Q:$D(APCHSQIT)
.. S APCHSDFN=0 F APCHQ=0:0 S APCHSDFN=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D EKGDSP Q:$D(APCHSQIT)
.. Q
. Q
;NOW DISPLAY EKG REFUSALS
Q:'$D(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002))
X APCHSCKP Q:$D(APCHSQIT)
;W ! ;,"Refusal of EKG: "
S APCHSD=0 F S APCHSD=$O(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD)) Q:APCHSD=""!(APCHSD>APCHSDLM)!($D(APCHSQIT)) D
.S APCHSI=0 F S APCHSI=$O(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD,APCHSI)) Q:APCHSI=""!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W !,$$DATE^APCHSMU(9999999-APCHSD),?12,"(",$$VAL^XBDIQ1(9000022,APCHSI,.07),")"," ",$$VAL^XBDIQ1(9000022,APCHSI,.04)
..Q
.Q
Q
;
EKGX ; exit EKG
;<CLEANUP>
K APCHSDP,APCHSDFN,APCHSNRQ,APCHSDAT,APCHSDS,APCHSN,APCHSIVD,APCHSVL,APCHSCNT,Y
Q
;
EKGDSP ;display EKG(S)
; <DISPLAY>
S APCHSN=^AUPNVDXP(APCHSDFN,0)
S APCHSDP=$P(APCHSN,U,1)
D GETEKG Q:APCHSDP=""
S APCHSCNT=APCHSCNT+1
S APCHSDS="DATE?"
S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDS=Y
S APCHSVL=$P($P(APCHSN,U,4),":")
S APCHSVL=$S(APCHSVL="N":"NORMAL",APCHSVL="A":"ABNORMAL",APCHSVL="B":"BORDERLINE",1:"<none recorded>") ;IHS/CMI/LAB added borderline
X APCHSCKP Q:$D(APCHSQIT)
W APCHSDS W ?12,APCHSDP,?30,"RESULT: ",APCHSVL,!
Q
GETEKG ;get EKG
S APCHSDP=$P(^AUTTDXPR(APCHSDP,0),U)
Q
APCHS8A ; IHS/CMI/LAB - PART 8A OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
+2 ;
EYERX ; *************** EYE GLASS PRESCRIPTIONS * 9000010.04 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVEYE("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+4 SET APCHSDT=$ORDER(^AUPNVEYE("AA",APCHSPAT,0))
+5 SET APCHSN=$ORDER(^AUPNVEYE("AA",APCHSPAT,APCHSDT,0))
+6 SET APCHSP=^AUPNVEYE(APCHSN,0)
SET APCHSVDF=$PIECE(APCHSP,U,3)
DO GETSITEV^APCHSUTL
+7 SET Y=-APCHSDT\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
BLD ; <BUILD>
+1 SET APCHSEN=$GET(^AUPNVEYE(APCHSN,19))
+2 SET APCHST="Reading only^^^^^^^^^^^^Pupil near^Pupil far"
+3 SET APCHSJ="1^^^^^^^^^2^2^4^2^2"
+4 SET APCHSL=""
FOR APCHSI=1,13
DO ADDTOL
+5 SET APCHSL1=$EXTRACT(APCHSL,3,255)
+6 SET APCHSL=""
FOR APCHSI=14
DO ADDTOL
+7 SET APCHSL2=$EXTRACT(APCHSL,3,255)
+8 SET APCHST=""
+9 SET APCHSL="R"
FOR APCHSI=2,3,4,15,8
DO BLDL
DSPLY ;<DISPLAY>
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSDAT,?10,APCHSNSH,!
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSDAT,?10,APCHSNSH,!
+3 WRITE " Sphere Cyl Axis Prism Add",!
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO NPG
WRITE APCHSL,?44,APCHSL1,!
+5 SET APCHSL="L"
FOR APCHSI=5,6,7,16,9
DO BLDL
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO NPG
WRITE APCHSL,?61,APCHSL2,!
EYEMEAS ;display eye care measurements
+1 KILL APCHSMT
+2 SET APCHSM=$ORDER(^AUTTMSR("C","07",0))
SET APCHSP=1
IF APCHSM
DO GATHER
+3 SET APCHSM=$ORDER(^AUTTMSR("C","08",0))
SET APCHSP=2
IF APCHSM
DO GATHER
+4 SET APCHSM=$ORDER(^AUTTMSR("C","11",0))
SET APCHSP=3
IF APCHSM
DO GATHER
+5 DO DISPEM
+6 ; <CLEANUP>
EYERXX KILL APCHSDAT,APCHSDT,APCHSEN,APCHSF,APCHSI,APCHSJ,APCHSL,APCHSL1,APCHSL2,APCHSN,APCHST,APCHSVDF,Y,APCHSM,APCHSVNM,APCHSMT,APCHSM,APCHSJ,APCHSX
+1 QUIT
GATHER ;gather up last 5 of measurement in array by inverse date
+1 SET (C,D,N)=0
FOR
SET D=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSM,D))
IF D'=+D
QUIT
SET N=0
FOR
SET N=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSM,D,N))
IF N'=+N!(C>3)
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^AUPNVMSR(N,2)),U,1)
QUIT
+3 SET C=C+1
SET $PIECE(APCHSMT(D),U,APCHSP)=$$VAL^XBDIQ1(9000010.01,N,.04)
End DoDot:1
+4 QUIT
DISPEM ;display eye measurements
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+2 WRITE !?29,"Eye Care Measurements"
+3 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+4 WRITE !?15,"VU",?34,"VC",?48,"TONOMETRY"
+5 SET APCHSX=0
FOR
SET APCHSX=$ORDER(APCHSMT(APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,$$FMTE^XLFDT((9999999-APCHSX),"2D")
SET APCHSJ="10;29;48"
FOR APCHST=1:1:3
WRITE ?$PIECE(APCHSJ,";",APCHST),$PIECE(APCHSMT(APCHSX),U,APCHST)
+6 QUIT
ADDTOL SET APCHSF=$PIECE(APCHSEN,U,APCHSI)
IF APCHSF=""
SET APCHSF="-"
SET APCHSF=$JUSTIFY(APCHSF,$PIECE(APCHSJ,U,APCHSI))
+1 IF APCHSF]""
SET APCHSL=APCHSL_" "_$PIECE(APCHST,U,APCHSI)_": "_APCHSF
+2 QUIT
BLDL SET APCHSF=$JUSTIFY($PIECE(APCHSEN,U,APCHSI),7)
+1 SET APCHSL=APCHSL_APCHSF
+2 QUIT
NPG WRITE APCHSDAT,?10,APCHSNSH,!
+1 WRITE " Sphere Cyl Axis Prism Add",!
+2 QUIT
+3 ;
+4 ;
EKG ; ***** EKG SUMMARY * 9000010.21 (V DIAGNOSTIC PROCEDURE RESULT) *****
+1 ;<setup>
+2 ;Q:'$D(^AUPNVDXP("AC",APCHSPAT))
+3 IF '$DATA(^AUPNVDXP("AC",APCHSPAT))
IF '$DATA(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002))
QUIT
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+5 SET APCHSCNT=0
+6 SET APCHSDAT=0
FOR APCHSQ=0:0
SET APCHSDAT=$ORDER(^AUPNVDXP("AA",APCHSPAT,APCHSDAT))
IF 'APCHSDAT
QUIT
Begin DoDot:1
+7 SET APCHSIVD=0
FOR APCHQ=0:0
SET APCHSIVD=$ORDER(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:2
+8 SET APCHSDFN=0
FOR APCHQ=0:0
SET APCHSDFN=$ORDER(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
DO EKGDSP
IF $DATA(APCHSQIT)
QUIT
+9 QUIT
End DoDot:2
IF $DATA(APCHSQIT)
QUIT
+10 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+11 ;NOW DISPLAY EKG REFUSALS
+12 IF '$DATA(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002))
QUIT
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 ;W ! ;,"Refusal of EKG: "
+15 SET APCHSD=0
FOR
SET APCHSD=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD))
IF APCHSD=""!(APCHSD>APCHSDLM)!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+16 SET APCHSI=0
FOR
SET APCHSI=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD,APCHSI))
IF APCHSI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 WRITE !,$$DATE^APCHSMU(9999999-APCHSD),?12,"(",$$VAL^XBDIQ1(9000022,APCHSI,.07),")"," ",$$VAL^XBDIQ1(9000022,APCHSI,.04)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
EKGX ; exit EKG
+1 ;<CLEANUP>
+2 KILL APCHSDP,APCHSDFN,APCHSNRQ,APCHSDAT,APCHSDS,APCHSN,APCHSIVD,APCHSVL,APCHSCNT,Y
+3 QUIT
+4 ;
EKGDSP ;display EKG(S)
+1 ; <DISPLAY>
+2 SET APCHSN=^AUPNVDXP(APCHSDFN,0)
+3 SET APCHSDP=$PIECE(APCHSN,U,1)
+4 DO GETEKG
IF APCHSDP=""
QUIT
+5 SET APCHSCNT=APCHSCNT+1
+6 SET APCHSDS="DATE?"
+7 SET Y=$PIECE(APCHSN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCHSCVD
SET APCHSDS=Y
+8 SET APCHSVL=$PIECE($PIECE(APCHSN,U,4),":")
+9 ;IHS/CMI/LAB added borderline
SET APCHSVL=$SELECT(APCHSVL="N":"NORMAL",APCHSVL="A":"ABNORMAL",APCHSVL="B":"BORDERLINE",1:"<none recorded>")
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE APCHSDS
WRITE ?12,APCHSDP,?30,"RESULT: ",APCHSVL,!
+12 QUIT
GETEKG ;get EKG
+1 SET APCHSDP=$PIECE(^AUTTDXPR(APCHSDP,0),U)
+2 QUIT
