BSDX41D ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
; <SETUP>
Q:'$D(^AUPNVMSR("AA",APCHSPAT))
X APCHSBRK
; <BUILD> APCHSCTL-HLTH SUM TYPE
F APCHSPOR=0:0 S APCHSPOR=$O(^APCHSCTL(APCHSTYP,3,APCHSPOR)) Q:'APCHSPOR S APCHSND2=APCHSNDM,APCHSDMX=0 D PBLD
;now display lab refusals
S APCHST="MEASUREMENT",APCHSFN=9999999.07 D DISPREF^APCHS3C
K APCHST,APCHSFN
MEASPX K APCHSPOR,APCHSPDF,APCHSCOR,APCHSCT,APCHSCT2,APCHSCT3,APCHSCLN,APCHSMT,APCHSML,APCHSTSQ,APCHSTVL,APCHSVAL,APCHSIVD,APCHST,APCHSC,APCHSND2,APCHSDMX,APCHSDFN,APCHSDAT,APCHSDM2,APCHSPS1,APCHSIDT,APCHSNTS,Y,X
Q
PBLD S APCHSPDF=$P(^APCHSCTL(APCHSTYP,3,APCHSPOR,0),U,2)
K APCHSTSQ,APCHSTVL,APCHSNTS
S APCHSNTS=0
F APCHSPS1=1,0 F APCHSCOR=0:0 S APCHSCOR=$O(^APCHSMPN(APCHSPDF,1,APCHSCOR)) Q:APCHSCOR="" D CBLD
D POUT
Q
CBLD S APCHSP=^APCHSMPN(APCHSPDF,1,APCHSCOR,0) S APCHSCT3=$G(^(1))
S APCHSCT=$P(APCHSP,U,2),APCHSCLN=$P(APCHSP,U,3)
S X=$P(APCHSP,U,5) S:X]"" APCHSNTS(X)=""
S:APCHSCT="" APCHSCT=" " S APCHSCT2=$S($D(^AUTTMSR(APCHSCT,0)):$P(^(0),U,1),1:APCHSCT)
S:$P(APCHSP,U,4)]"" APCHSCT2=$P(APCHSP,U,4)
S:APCHSCLN="" APCHSCLN=10
S APCHSTSQ(APCHSCOR,1)=APCHSCT2,APCHSTSQ(APCHSCOR,2)=APCHSCLN,APCHSTSQ(APCHSCOR,3)=APCHSCT3
I APCHSPS1 S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D CBLD2
I 'APCHSPS1 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,0)) I APCHSIVD,'$D(APCHSTVL(APCHSIVD,APCHSCOR)) D CBLD3
Q
CBLD2 I '$D(APCHSTVL(APCHSIVD)) S APCHSND2=APCHSND2-1 I APCHSND2=-1 S APCHSND2=0 Q:APCHSDMX&(APCHSIVD'<APCHSDMX) K APCHSTVL(APCHSDMX) F APCHSDM2=0:0 S APCHSDM2=$O(APCHSTVL(APCHSDM2)) Q:'APCHSDM2 S APCHSDMX=APCHSDM2
S:APCHSIVD>APCHSDMX APCHSDMX=APCHSIVD
CBLD3 S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD,"")),APCHSVAL=$P(^AUPNVMSR(APCHSDFN,0),U,4),APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$P(^AUPNVMSR(APCHSDFN,0),U,6)
Q
; <DISPLAY>
POUT X APCHSCKP Q:$D(APCHSQIT) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
X APCHSCKP Q:$D(APCHSQIT) D PHDR
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(APCHSTVL(APCHSIVD)) Q:APCHSIVD="" X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG PHDR D PLINE
I $O(APCHSNTS(0))]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) S X="" F S X=$O(APCHSNTS(X)) Q:X="" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=X_$C(30)
Q
PHDR S APCHST=10,APCHSC=""
F APCHSQ=0:0 S APCHSC=$O(APCHSTSQ(APCHSC)) Q:APCHSC="" S APCHSMT=APCHSTSQ(APCHSC,1),APCHSML=APCHSTSQ(APCHSC,2) S BSDXTMP=$$FILL^BSDX41(APCHST+1+(APCHSML-$L(APCHSMT)\2))_APCHSMT S APCHST=APCHST+APCHSML+2
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
Q
PLINE S APCHSIDT=APCHSIVD,Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
S BSDXTMP=APCHSDAT S APCHST=11
S APCHSC="" F APCHSQ=0:0 S APCHSC=$O(APCHSTSQ(APCHSC)) Q:APCHSC="" D PVAL
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
Q
PVAL ;
K APCHSVNM
S APCHSML=APCHSTSQ(APCHSC,2)
S (APCHSVAL,APCHSVNM)="",APCHSVAL=$P($G(APCHSTVL(APCHSIVD,APCHSC)),U) I $P($G(APCHSTVL(APCHSIVD,APCHSC)),U,2)]"" S APCHSVNM=$P($G(APCHSTVL(APCHSIVD,APCHSC)),U,2)
I APCHSVAL]"" S X=APCHSVAL X APCHSTSQ(APCHSC,3) S APCHSVAL=$P(X,"^",1),X=$P(X,"^",2) S:X]"" APCHSNTS(X)=""
S:APCHSVAL]"" APCHSVAL=$S($P(APCHSML,".",2)="":$J(APCHSVAL,$P(APCHSML,".",1)),1:$J(APCHSVAL,$P(APCHSML,".",1),$P(APCHSML,".",2)))
S BSDXTMP=BSDXTMP_$$FILL^BSDX41(APCHST)_APCHSVAL S APCHST=APCHST+APCHSML+2
K APCHSVNM
Q
;
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) S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(30)
X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG BSDXTMP=BSDXTMP_APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(10,13)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" Sphere Cyl Axis Prism Add"_$C(30)
X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG NPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSL_$$FILL^BSDX41(44-$L(APCHSL))_APCHSL1_$C(30)
S APCHSL="L" F APCHSI=5,6,7,16,9 D BLDL
X APCHSCKP Q:$D(APCHSQIT) D:APCHSNPG NPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSL_$$FILL^BSDX41(61-$L(APCHSL))_APCHSL2_$C(30)
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) 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)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXTMP=$$FILL^BSDX41(29)_"Eye Care Measurements"
X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
S BSDXDSP=$$FILL^BSDX41(15)_"VU"
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(34-$L(BSDXDSP))_"VC"
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(48-$L(BSDXDSP))_"TONOMETRY"
S BSDXTMP=BSDXTMP__BSDXDSP
S APCHSX=0 F S APCHSX=$O(APCHSMT(APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) X APCHSCKP Q:$D(APCHSQIT) D
. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
. S BSDXDSP=$$FMTE^XLFDT((9999999-APCHSX),"2D")
. S APCHSJ="10;29;48"
. F APCHST=1:1:3 S BSDXDSP=BSDXDSP_$$FILL^BSDX41($P(APCHSJ,";",APCHST)-$L(BSDXDSP))_$P(APCHSMT(APCHSX),U,APCHST)
. S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
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 S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(30)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" Sphere Cyl Axis Prism Add"_$C(30)
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)
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)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
..S BSDXDSP=$$DATE^APCHSMU(9999999-APCHSD)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$$FILL^BSDX41(12-$L(BSDXDSP))_"("_$$VAL^XBDIQ1(9000022,APCHSI,.07)_")"_" "_$$VAL^XBDIQ1(9000022,APCHSI,.04)_$C(30)
..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>")
X APCHSCKP Q:$D(APCHSQIT)
S BSDXDSP=APCHSDS
S BSDXDSP=BSDXDSP_$$FILL^BSDX41(12-$L(BSDXDSP))_APCHSDP
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_"RESULT: "_APCHSVL_$C(30)
Q
GETEKG ;get EKG
S APCHSDP=$P(^AUTTDXPR(APCHSDP,0),U)
Q
BSDX41D ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
+1 ; <SETUP>
+2 IF '$DATA(^AUPNVMSR("AA",APCHSPAT))
QUIT
+3 XECUTE APCHSBRK
+4 ; <BUILD> APCHSCTL-HLTH SUM TYPE
+5 FOR APCHSPOR=0:0
SET APCHSPOR=$ORDER(^APCHSCTL(APCHSTYP,3,APCHSPOR))
IF 'APCHSPOR
QUIT
SET APCHSND2=APCHSNDM
SET APCHSDMX=0
DO PBLD
+6 ;now display lab refusals
+7 SET APCHST="MEASUREMENT"
SET APCHSFN=9999999.07
DO DISPREF^APCHS3C
+8 KILL APCHST,APCHSFN
MEASPX KILL APCHSPOR,APCHSPDF,APCHSCOR,APCHSCT,APCHSCT2,APCHSCT3,APCHSCLN,APCHSMT,APCHSML,APCHSTSQ,APCHSTVL,APCHSVAL,APCHSIVD,APCHST,APCHSC,APCHSND2,APCHSDMX,APCHSDFN,APCHSDAT,APCHSDM2,APCHSPS1,APCHSIDT,APCHSNTS,Y,X
+1 QUIT
PBLD SET APCHSPDF=$PIECE(^APCHSCTL(APCHSTYP,3,APCHSPOR,0),U,2)
+1 KILL APCHSTSQ,APCHSTVL,APCHSNTS
+2 SET APCHSNTS=0
+3 FOR APCHSPS1=1,0
FOR APCHSCOR=0:0
SET APCHSCOR=$ORDER(^APCHSMPN(APCHSPDF,1,APCHSCOR))
IF APCHSCOR=""
QUIT
DO CBLD
+4 DO POUT
+5 QUIT
CBLD SET APCHSP=^APCHSMPN(APCHSPDF,1,APCHSCOR,0)
SET APCHSCT3=$GET(^(1))
+1 SET APCHSCT=$PIECE(APCHSP,U,2)
SET APCHSCLN=$PIECE(APCHSP,U,3)
+2 SET X=$PIECE(APCHSP,U,5)
IF X]""
SET APCHSNTS(X)=""
+3 IF APCHSCT=""
SET APCHSCT=" "
SET APCHSCT2=$SELECT($DATA(^AUTTMSR(APCHSCT,0)):$PIECE(^(0),U,1),1:APCHSCT)
+4 IF $PIECE(APCHSP,U,4)]""
SET APCHSCT2=$PIECE(APCHSP,U,4)
+5 IF APCHSCLN=""
SET APCHSCLN=10
+6 SET APCHSTSQ(APCHSCOR,1)=APCHSCT2
SET APCHSTSQ(APCHSCOR,2)=APCHSCLN
SET APCHSTSQ(APCHSCOR,3)=APCHSCT3
+7 IF APCHSPS1
SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO CBLD2
+8 IF 'APCHSPS1
SET APCHSIVD=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,0))
IF APCHSIVD
IF '$DATA(APCHSTVL(APCHSIVD,APCHSCOR))
DO CBLD3
+9 QUIT
CBLD2 IF '$DATA(APCHSTVL(APCHSIVD))
SET APCHSND2=APCHSND2-1
IF APCHSND2=-1
SET APCHSND2=0
IF APCHSDMX&(APCHSIVD'<APCHSDMX)
QUIT
KILL APCHSTVL(APCHSDMX)
FOR APCHSDM2=0:0
SET APCHSDM2=$ORDER(APCHSTVL(APCHSDM2))
IF 'APCHSDM2
QUIT
SET APCHSDMX=APCHSDM2
+1 IF APCHSIVD>APCHSDMX
SET APCHSDMX=APCHSIVD
CBLD3 SET APCHSDFN=$ORDER(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD,""))
SET APCHSVAL=$PIECE(^AUPNVMSR(APCHSDFN,0),U,4)
SET APCHSTVL(APCHSIVD,APCHSCOR)=APCHSVAL_"^"_$PIECE(^AUPNVMSR(APCHSDFN,0),U,6)
+1 QUIT
+2 ; <DISPLAY>
POUT XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO PHDR
+2 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(APCHSTVL(APCHSIVD))
IF APCHSIVD=""
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO PHDR
DO PLINE
+3 IF $ORDER(APCHSNTS(0))]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
SET X=""
FOR
SET X=$ORDER(APCHSNTS(X))
IF X=""
QUIT
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=X_$CHAR(30)
+4 QUIT
PHDR SET APCHST=10
SET APCHSC=""
+1 FOR APCHSQ=0:0
SET APCHSC=$ORDER(APCHSTSQ(APCHSC))
IF APCHSC=""
QUIT
SET APCHSMT=APCHSTSQ(APCHSC,1)
SET APCHSML=APCHSTSQ(APCHSC,2)
SET BSDXTMP=$$FILL^BSDX41(APCHST+1+(APCHSML-$LENGTH(APCHSMT)\2))_APCHSMT
SET APCHST=APCHST+APCHSML+2
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+3 QUIT
PLINE SET APCHSIDT=APCHSIVD
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+1 SET BSDXTMP=APCHSDAT
SET APCHST=11
+2 SET APCHSC=""
FOR APCHSQ=0:0
SET APCHSC=$ORDER(APCHSTSQ(APCHSC))
IF APCHSC=""
QUIT
DO PVAL
+3 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+4 QUIT
PVAL ;
+1 KILL APCHSVNM
+2 SET APCHSML=APCHSTSQ(APCHSC,2)
+3 SET (APCHSVAL,APCHSVNM)=""
SET APCHSVAL=$PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U)
IF $PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U,2)]""
SET APCHSVNM=$PIECE($GET(APCHSTVL(APCHSIVD,APCHSC)),U,2)
+4 IF APCHSVAL]""
SET X=APCHSVAL
XECUTE APCHSTSQ(APCHSC,3)
SET APCHSVAL=$PIECE(X,"^",1)
SET X=$PIECE(X,"^",2)
IF X]""
SET APCHSNTS(X)=""
+5 IF APCHSVAL]""
SET APCHSVAL=$SELECT($PIECE(APCHSML,".",2)="":$JUSTIFY(APCHSVAL,$PIECE(APCHSML,".",1)),1:$JUSTIFY(APCHSVAL,$PIECE(APCHSML,".",1),$PIECE(APCHSML,".",2)))
+6 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(APCHST)_APCHSVAL
SET APCHST=APCHST+APCHSML+2
+7 KILL APCHSVNM
+8 QUIT
+9 ;
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
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$LENGTH(APCHSDAT))_APCHSNSH_$CHAR(30)
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET BSDXTMP=BSDXTMP_APCHSDAT_$$FILL^BSDX41(10-$LENGTH(APCHSDAT))_APCHSNSH_$CHAR(10,13)
+3 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" Sphere Cyl Axis Prism Add"_$CHAR(30)
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO NPG
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSL_$$FILL^BSDX41(44-$LENGTH(APCHSL))_APCHSL1_$CHAR(30)
+5 SET APCHSL="L"
FOR APCHSI=5,6,7,16,9
DO BLDL
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
DO NPG
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSL_$$FILL^BSDX41(61-$LENGTH(APCHSL))_APCHSL2_$CHAR(30)
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
SET C=C+1
SET $PIECE(APCHSMT(D),U,APCHSP)=$$VAL^XBDIQ1(9000010.01,N,.04)
+2 QUIT
DISPEM ;display eye measurements
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+2 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+3 SET BSDXTMP=$$FILL^BSDX41(29)_"Eye Care Measurements"
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+6 SET BSDXDSP=$$FILL^BSDX41(15)_"VU"
+7 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(34-$LENGTH(BSDXDSP))_"VC"
+8 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(48-$LENGTH(BSDXDSP))_"TONOMETRY"
+9 SET BSDXTMP=BSDXTMP__BSDXDSP
+10 SET APCHSX=0
FOR
SET APCHSX=$ORDER(APCHSMT(APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:1
+11 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+12 SET BSDXDSP=$$FMTE^XLFDT((9999999-APCHSX),"2D")
+13 SET APCHSJ="10;29;48"
+14 FOR APCHST=1:1:3
SET BSDXDSP=BSDXDSP_$$FILL^BSDX41($PIECE(APCHSJ,";",APCHST)-$LENGTH(BSDXDSP))_$PIECE(APCHSMT(APCHSX),U,APCHST)
+15 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$CHAR(30)
End DoDot:1
+16 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 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$LENGTH(APCHSDAT))_APCHSNSH_$CHAR(30)
+1 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" Sphere Cyl Axis Prism Add"_$CHAR(30)
+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 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
+15 SET APCHSI=0
FOR
SET APCHSI=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD,APCHSI))
IF APCHSI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+17 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+18 SET BSDXDSP=$$DATE^APCHSMU(9999999-APCHSD)
+19 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$$FILL^BSDX41(12-$LENGTH(BSDXDSP))_"("_$$VAL^XBDIQ1(9000022,APCHSI,.07)_")"_" "_$$VAL^XBDIQ1(9000022,APCHSI,.04)_$CHAR(30)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
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 SET APCHSVL=$SELECT(APCHSVL="N":"NORMAL",APCHSVL="A":"ABNORMAL",APCHSVL="B":"BORDERLINE",1:"<none recorded>")
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 SET BSDXDSP=APCHSDS
+12 SET BSDXDSP=BSDXDSP_$$FILL^BSDX41(12-$LENGTH(BSDXDSP))_APCHSDP
+13 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXDSP_$$FILL^BSDX41(30-$LENGTH(BSDXDSP))_"RESULT: "_APCHSVL_$CHAR(30)
+14 QUIT
GETEKG ;get EKG
+1 SET APCHSDP=$PIECE(^AUTTDXPR(APCHSDP,0),U)
+2 QUIT
