Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDX41D

BSDX41D.m

Go to the documentation of this file. 
  1. BSDX41D ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
  1.  ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
  1.  ;
  1. MEASP ; ******************** MEASUREMENT PANELS * 9000010.01 *******
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVMSR("AA",APCHSPAT))
  1.  X APCHSBRK
  1.  ; <BUILD>  APCHSCTL-HLTH SUM TYPE
  1.  F APCHSPOR=0:0 S APCHSPOR=$O(^APCHSCTL(APCHSTYP,3,APCHSPOR)) Q:'APCHSPOR  S APCHSND2=APCHSNDM,APCHSDMX=0 D PBLD
  1.  ;now display lab refusals
  1.  S APCHST="MEASUREMENT",APCHSFN=9999999.07 D DISPREF^APCHS3C
  1.  K APCHST,APCHSFN
  1. 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
  1.  Q
  1. PBLD S APCHSPDF=$P(^APCHSCTL(APCHSTYP,3,APCHSPOR,0),U,2)
  1.  K APCHSTSQ,APCHSTVL,APCHSNTS
  1.  S APCHSNTS=0
  1.  F APCHSPS1=1,0 F APCHSCOR=0:0 S APCHSCOR=$O(^APCHSMPN(APCHSPDF,1,APCHSCOR)) Q:APCHSCOR=""  D CBLD
  1.  D POUT
  1.  Q
  1. CBLD S APCHSP=^APCHSMPN(APCHSPDF,1,APCHSCOR,0) S APCHSCT3=$G(^(1))
  1.  S APCHSCT=$P(APCHSP,U,2),APCHSCLN=$P(APCHSP,U,3)
  1.  S X=$P(APCHSP,U,5) S:X]"" APCHSNTS(X)=""
  1.  S:APCHSCT="" APCHSCT=" " S APCHSCT2=$S($D(^AUTTMSR(APCHSCT,0)):$P(^(0),U,1),1:APCHSCT)
  1.  S:$P(APCHSP,U,4)]"" APCHSCT2=$P(APCHSP,U,4)
  1.  S:APCHSCLN="" APCHSCLN=10
  1.  S APCHSTSQ(APCHSCOR,1)=APCHSCT2,APCHSTSQ(APCHSCOR,2)=APCHSCLN,APCHSTSQ(APCHSCOR,3)=APCHSCT3
  1.  I APCHSPS1 S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D CBLD2
  1.  I 'APCHSPS1 S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSCT,0)) I APCHSIVD,'$D(APCHSTVL(APCHSIVD,APCHSCOR)) D CBLD3
  1.  Q
  1. 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
  1.  S:APCHSIVD>APCHSDMX APCHSDMX=APCHSIVD
  1. 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)
  1.  Q
  1.  ; <DISPLAY>
  1. POUT X APCHSCKP Q:$D(APCHSQIT)  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  X APCHSCKP Q:$D(APCHSQIT)  D PHDR
  1.  S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(APCHSTVL(APCHSIVD)) Q:APCHSIVD=""  X APCHSCKP Q:$D(APCHSQIT)  D:APCHSNPG PHDR D PLINE
  1.  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)
  1.  Q
  1. PHDR S APCHST=10,APCHSC=""
  1.  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
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  Q
  1. PLINE S APCHSIDT=APCHSIVD,Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
  1.  S BSDXTMP=APCHSDAT S APCHST=11
  1.  S APCHSC="" F APCHSQ=0:0 S APCHSC=$O(APCHSTSQ(APCHSC)) Q:APCHSC=""  D PVAL
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  Q
  1. PVAL ;
  1.  K APCHSVNM
  1.  S APCHSML=APCHSTSQ(APCHSC,2)
  1.  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)
  1.  I APCHSVAL]"" S X=APCHSVAL X APCHSTSQ(APCHSC,3) S APCHSVAL=$P(X,"^",1),X=$P(X,"^",2) S:X]"" APCHSNTS(X)=""
  1.  S:APCHSVAL]"" APCHSVAL=$S($P(APCHSML,".",2)="":$J(APCHSVAL,$P(APCHSML,".",1)),1:$J(APCHSVAL,$P(APCHSML,".",1),$P(APCHSML,".",2)))
  1.  S BSDXTMP=BSDXTMP_$$FILL^BSDX41(APCHST)_APCHSVAL S APCHST=APCHST+APCHSML+2
  1.  K APCHSVNM
  1.  Q
  1.  ;
  1. EYERX ; *************** EYE GLASS PRESCRIPTIONS * 9000010.04 *******
  1.  ; <SETUP>
  1.  Q:'$D(^AUPNVEYE("AA",APCHSPAT))
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  S APCHSDT=$O(^AUPNVEYE("AA",APCHSPAT,0))
  1.  S APCHSN=$O(^AUPNVEYE("AA",APCHSPAT,APCHSDT,0))
  1.  S APCHSP=^AUPNVEYE(APCHSN,0),APCHSVDF=$P(APCHSP,U,3) D GETSITEV^APCHSUTL
  1.  S Y=-APCHSDT\1+9999999 X APCHSCVD S APCHSDAT=Y
  1. BLD ; <BUILD>
  1.  S APCHSEN=$G(^AUPNVEYE(APCHSN,19))
  1.  S APCHST="Reading only^^^^^^^^^^^^Pupil near^Pupil  far"
  1.  S APCHSJ="1^^^^^^^^^2^2^4^2^2"
  1.  S APCHSL="" F APCHSI=1,13 D ADDTOL
  1.  S APCHSL1=$E(APCHSL,3,255)
  1.  S APCHSL="" F APCHSI=14 D ADDTOL
  1.  S APCHSL2=$E(APCHSL,3,255)
  1.  S APCHST=""
  1.  S APCHSL="R" F APCHSI=2,3,4,15,8 D BLDL
  1. DSPLY ;<DISPLAY>
  1.  X APCHSCKP Q:$D(APCHSQIT)  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(30)
  1.  X APCHSCKP Q:$D(APCHSQIT)  S:APCHSNPG BSDXTMP=BSDXTMP_APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(10,13)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  Sphere    Cyl   Axis  Prism  Add"_$C(30)
  1.  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)
  1.  S APCHSL="L" F APCHSI=5,6,7,16,9 D BLDL
  1.  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)
  1. EYEMEAS ;display eye care measurements
  1.  K APCHSMT
  1.  S APCHSM=$O(^AUTTMSR("C","07",0)),APCHSP=1 I APCHSM D GATHER
  1.  S APCHSM=$O(^AUTTMSR("C","08",0)),APCHSP=2 I APCHSM D GATHER
  1.  S APCHSM=$O(^AUTTMSR("C","11",0)),APCHSP=3 I APCHSM D GATHER
  1.  D DISPEM
  1.  ; <CLEANUP>
  1. EYERXX K APCHSDAT,APCHSDT,APCHSEN,APCHSF,APCHSI,APCHSJ,APCHSL,APCHSL1,APCHSL2,APCHSN,APCHST,APCHSVDF,Y,APCHSM,APCHSVNM,APCHSMT,APCHSM,APCHSJ,APCHSX
  1.  Q
  1. GATHER ;gather up last 5 of measurement in array by inverse date
  1.  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)
  1.  Q
  1. DISPEM ;display eye measurements
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  S BSDXTMP=$$FILL^BSDX41(29)_"Eye Care Measurements"
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  S BSDXDSP=$$FILL^BSDX41(15)_"VU"
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(34-$L(BSDXDSP))_"VC"
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(48-$L(BSDXDSP))_"TONOMETRY"
  1.  S BSDXTMP=BSDXTMP__BSDXDSP
  1.  S APCHSX=0 F  S APCHSX=$O(APCHSMT(APCHSX)) Q:APCHSX=""!($D(APCHSQIT))  X APCHSCKP Q:$D(APCHSQIT)  D
  1.  . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
  1.  . S BSDXDSP=$$FMTE^XLFDT((9999999-APCHSX),"2D")
  1.  . S APCHSJ="10;29;48"
  1.  . F APCHST=1:1:3 S BSDXDSP=BSDXDSP_$$FILL^BSDX41($P(APCHSJ,";",APCHST)-$L(BSDXDSP))_$P(APCHSMT(APCHSX),U,APCHST)
  1.  . S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$C(30)
  1.  Q
  1. ADDTOL S APCHSF=$P(APCHSEN,U,APCHSI) S:APCHSF="" APCHSF="-" S APCHSF=$J(APCHSF,$P(APCHSJ,U,APCHSI))
  1.  S:APCHSF]"" APCHSL=APCHSL_"  "_$P(APCHST,U,APCHSI)_": "_APCHSF
  1.  Q
  1. BLDL S APCHSF=$J($P(APCHSEN,U,APCHSI),7)
  1.  S APCHSL=APCHSL_APCHSF
  1.  Q
  1. NPG S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=APCHSDAT_$$FILL^BSDX41(10-$L(APCHSDAT))_APCHSNSH_$C(30)
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)="  Sphere    Cyl   Axis  Prism  Add"_$C(30)
  1.  Q
  1.  ;
  1.  ;
  1. EKG ; ***** EKG SUMMARY * 9000010.21 (V DIAGNOSTIC PROCEDURE RESULT) *****
  1.  ;<setup>
  1.  ;Q:'$D(^AUPNVDXP("AC",APCHSPAT))
  1.  I '$D(^AUPNVDXP("AC",APCHSPAT)),'$D(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002)) Q
  1.  X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
  1.  S APCHSCNT=0
  1.  S APCHSDAT=0 F APCHSQ=0:0 S APCHSDAT=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT)) Q:'APCHSDAT  D  Q:$D(APCHSQIT)
  1.  . S APCHSIVD=0 F APCHQ=0:0 S APCHSIVD=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  D  Q:$D(APCHSQIT)
  1.  .. S APCHSDFN=0 F APCHQ=0:0 S APCHSDFN=$O(^AUPNVDXP("AA",APCHSPAT,APCHSDAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN  D EKGDSP Q:$D(APCHSQIT)
  1.  .. Q
  1.  . Q
  1.  ;NOW DISPLAY EKG REFUSALS
  1.  Q:'$D(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002))
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S APCHSD=0 F  S APCHSD=$O(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD)) Q:APCHSD=""!(APCHSD>APCHSDLM)!($D(APCHSQIT))  D
  1.  .S APCHSI=0 F  S APCHSI=$O(^AUPNPREF("AA",APCHSPAT,9999999.68,691.500002,APCHSD,APCHSI)) Q:APCHSI=""!($D(APCHSQIT))  D
  1.  ..X APCHSCKP Q:$D(APCHSQIT)
  1.  ..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
  1.  ..S BSDXDSP=$$DATE^APCHSMU(9999999-APCHSD)
  1.  ..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)
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. EKGX ; exit EKG
  1.  ;<CLEANUP>
  1.  K APCHSDP,APCHSDFN,APCHSNRQ,APCHSDAT,APCHSDS,APCHSN,APCHSIVD,APCHSVL,APCHSCNT,Y
  1.  Q
  1.  ;
  1. EKGDSP ;display EKG(S)
  1.  ; <DISPLAY>
  1.  S APCHSN=^AUPNVDXP(APCHSDFN,0)
  1.  S APCHSDP=$P(APCHSN,U,1)
  1.  D GETEKG Q:APCHSDP=""
  1.  S APCHSCNT=APCHSCNT+1
  1.  S APCHSDS="DATE?"
  1.  S Y=$P(APCHSN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCHSCVD S APCHSDS=Y
  1.  S APCHSVL=$P($P(APCHSN,U,4),":")
  1.  S APCHSVL=$S(APCHSVL="N":"NORMAL",APCHSVL="A":"ABNORMAL",APCHSVL="B":"BORDERLINE",1:"<none recorded>")
  1.  X APCHSCKP Q:$D(APCHSQIT)
  1.  S BSDXDSP=APCHSDS
  1.  S BSDXDSP=BSDXDSP_$$FILL^BSDX41(12-$L(BSDXDSP))_APCHSDP
  1.  S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXDSP_$$FILL^BSDX41(30-$L(BSDXDSP))_"RESULT: "_APCHSVL_$C(30)
  1.  Q
  1. GETEKG ;get EKG
  1.  S APCHSDP=$P(^AUTTDXPR(APCHSDP,0),U)
  1.  Q