- 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
