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

BGOVEYE.m

Go to the documentation of this file. 
  1. BGOVEYE ; IHS/MSC/MGH - V EyeGlass Management ;10-Jul-2014 12:07;MGH
  1.  ;;1.1;BGO COMPONENTS;**11,14**;Mar 20, 2007;Build 2
  1.  ;----------------------------------------------------------------
  1.  ; Return last eyeglass record for a patient
  1.  ;  DFN = Patient IEN
  1.  ; .RET = Returned as a list of records:
  1.  ;  RET(1)=IEN [1] ^ Visit Date [2] ^Facility Name [3] ^Provider IEN [4] ^ Location Name [5] ^ Entered Date [6] ^ Visit IEN [7] ^ Visit Category [8] ^ Visit Locked [9]
  1.  ;  RET(2)=Left sphere [1] ^ left cyl [2] ^ left axis [3] ^ L prism H [4] ^ L Prism HD [5] ^ L Prism V [6] ^ L Prism VD [7] ^ L reading [8]
  1.  ;  RET(3)=Right sphere [1] ^ Right cyl [2] ^ Right axis [3] ^ R prism H [4] ^ R Prism HD [5] ^ R Prism V [6] ^ R Prism VD [7] ^ R reading [8]
  1.  ;  RET(4)=Reading [1] ^ PD Near [2] ^ PD Far [3] ^ LPD [4] ^ RPD [5]
  1.  ;  RET(5)=Comment
  1. GET(RET,DFN,VIEN) ;EP
  1.  N X,CNT,REC,VCAT,EYE,VDT,IND,LOC,FAC,FACNAM,EXNAME,PRVIEN,PRVNAME,EDATA,READ
  1.  N FNUM,VDATE,EDATE,COMMENT,EYE,LSPHERE,RSPHERE,LAXIS,RAXIS,LCYL,RCYL,LPD,RPD,LREAD,RREAD
  1.  N LPRISMH,PDNEAR,PDFAR,LRPISMH,LPRISMHN,LPRISMHV,LPRISMV,LPRISMVN,LPRISMVV,RPRISMH,RPRISMHN,RPRISMV,RPRISMHV,RPRISMVN,RPRISMVV
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S CNT=0
  1.  I $G(VIEN)'="" D
  1.  .;Get eyeglass prescription for the visit
  1.  .S EYE=$C(0)
  1.  .S EYE=$O(^AUPNVEYE("AD",VIEN,EYE),-1) Q:'EYE  D
  1.  ..S REC=$G(^AUPNVEYE(EYE,0))
  1.  ..Q:REC=""
  1.  ..D DATA
  1.  E  D
  1.  .;Get last eyeglass prescription
  1.  .S VDT=0
  1.  .S VDT=$O(^AUPNVEYE("AA",DFN,VDT)) Q:'VDT  D
  1.  ..S EYE=$C(0)
  1.  ..F  S EYE=$O(^AUPNVEYE("AA",DFN,VDT,EYE),-1) Q:'EYE  D
  1.  ...S REC=$G(^AUPNVEYE(EYE,0))
  1.  ...Q:REC=""
  1.  ...D DATA
  1.  Q
  1. DATA S FNUM=$$FNUM
  1.  ;Get visit data
  1.  S PRVIEN=$P($G(^AUPNVEYE(EYE,12)),U,4)
  1.  S PRVNAME=$S('PRVIEN:"",1:$P($G(^VA(200,+PRVIEN,0)),U))
  1.  S VIEN=$P(REC,U,3)
  1.  Q:'VIEN
  1.  S LOC=$P($G(^AUPNVSIT(VIEN,0)),U,6)
  1.  S FAC=$S(LOC:$P($G(^AUTTLOC(LOC,0)),U,10),1:"")
  1.  S FACNAM=$S(LOC:$P($G(^AUTTLOC(LOC,0)),U),1:"")
  1.  S:FACNAM FACNAM=$P($G(^DIC(4,FACNAM,0)),U)
  1.  S:$P($G(^AUPNVSIT(VIEN,21)),U)'="" FACNAM=$P(^(21),U)
  1.  S VCAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
  1.  I '$D(VDT) D
  1.  .S VDATE=$P($P($G(^AUPNVSIT(VIEN,0)),U,1),".",1)
  1.  .S VDT=9999999-VDATE
  1.  E  S VDATE=9999999-VDT
  1.  S EDATE=$P($G(^AUPNVEYE(EYE,12)),U,1)
  1.  I EDATE="" S EDATE=VDATE
  1.  ;Get right eye data
  1.  S EDATA=$G(^AUPNVEYE(EYE,19))
  1.  S RSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$P(EDATA,U,2))
  1.  S RCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,3))
  1.  S RAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,4))
  1.  S RREAD=$$EXTERNAL^DILFD(FNUM,1908,,$P(EDATA,U,8))
  1.  S RPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$P(EDATA,U,15))
  1.  S RPRISMHN=+$G(RPRISMH)
  1.  I RPRISMHN=0 S RPRISMHN=""
  1.  S RPRISMHV=$S(RPRISMH["BI":"BI",RPRISMH["BO":"BO",RPRISMH["BU":"BU",RPRISMH["BD":"BD",1:"")
  1.  S RPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$P(EDATA,U,17))
  1.  S RPRISMVN=+$G(RPRISMV)
  1.  I RPRISMVN=0 S RPRISMVN=""
  1.  S RPRISMVV=$S(RPRISMV["BI":"BI",RPRISMV["BO":"BO",RPRISMV["BU":"BU",RPRISMV["BD":"BD",1:"")
  1.  S RPD=$$EXTERNAL^DILFD(FNUM,1920,,$P(EDATA,U,20))
  1.  ;Get left eye data
  1.  S LSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$P(EDATA,U,5))
  1.  S LCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,6))
  1.  S LAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,7))
  1.  S LREAD=$$EXTERNAL^DILFD(FNUM,1909,,$P(EDATA,U,9))
  1.  S LPRISMH=$$EXTERNAL^DILFD(FNUM,1916,,$P(EDATA,U,16))
  1.  S LPRISMHN=+$G(LPRISMH)
  1.  I LPRISMHN=0 S LPRISMHN=""
  1.  S LPRISMHV=$S(LPRISMH["BI":"BI",LPRISMH["BO":"BO",LPRISMH["BU":"BU",LPRISMH["BD":"BD",1:"")
  1.  S LPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$P(EDATA,U,18))
  1.  S LPRISMVN=+$G(LPRISMV)
  1.  I LPRISMVN=0 S LPRISMVN=""
  1.  S LPRISMVV=$S(LPRISMV["BI":"BI",LPRISMV["BO":"BO",LPRISMV["BU":"BU",LPRISMV["BD":"BD",1:"")
  1.  S LPD=$$EXTERNAL^DILFD(FNUM,1919,,$P(EDATA,U,19))
  1.  ;Pupil distance
  1.  S PDNEAR=$$EXTERNAL^DILFD(FNUM,1913,,$P(EDATA,U,13))
  1.  S PDFAR=$$EXTERNAL^DILFD(FNUM,1914,,$P(EDATA,U,14))
  1.  S READ=$$EXTERNAL^DILFD(FNUM,1901,,$P(EDATA,U,1))
  1.  S COMMENT=$G(^AUPNVEYE(EYE,11))
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)=EYE_U_VDATE_U_FACNAM_U_PRVIEN_U_LOC_U_EDATE_U_VIEN_U_VCAT_U_$$ISLOCKED^BEHOENCX(VIEN)
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)=LSPHERE_U_LCYL_U_LAXIS_U_LPRISMHN_U_LPRISMHV_U_LPRISMVN_U_LPRISMVV_U_LREAD
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)=RSPHERE_U_RCYL_U_RAXIS_U_RPRISMHN_U_RPRISMHV_U_RPRISMVN_U_RPRISMVV_U_RREAD
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)=READ_U_PDNEAR_U_PDFAR_U_LPD_U_RPD
  1.  S CNT=CNT+1
  1.  S @RET@(CNT)=COMMENT
  1.  Q
  1.  ; Delete a V EYE GLASS
  1.  ;  INP = IEN
  1. DEL(RET,INP) ;EP
  1.  N IEN,REFUSAL
  1.  S IEN=+INP
  1.  I 'IEN S RET=$$ERR^BGOUTL(1008)
  1.  E  D VFDEL^BGOUTL2(.RET,$$FNUM,IEN)
  1.  Q
  1.  ; Set eyeglass prescription record
  1.  ; DATA is an array
  1.  ; DATA(0)=V File IEN (if edit) [1] ^ Patient ien [2] ^ visit ien [3] ^ provider [4] ^Event Date [5] ^ Location IEN [6] ^ Other Location [7] ^ Historical Flag [8]
  1.  ; DATA(1)=Left sphere [1] ^ left cyl [2] ^ left axis [3] ^ L prism H [4] ^ L Prism HD [5] ^ L Prism V [6] ^ L Prism VD [7] ^ L reading [8]
  1.  ; DATA(2)=Right sphere [1] ^ Right cyl [2] ^ Right axis [3] ^ R prism H [4] ^ R Prism HD [5] ^ R Prism V [6] ^ R Prism VD [7] ^ R reading [8]
  1.  ; DATA(3)=Reading [1] ^ PD Near [2] ^ PD Far [3] ^ LPD [4] ^ RPD [5]
  1.  ; DATA(4)=Comment
  1.  ; .RET = Returned as -1^error text if error
  1. SET(RET,DATA) ;EP
  1.  N VFIEN,VCAT,TYPE,VIEN,DFN,PROV,RESULT,COMMENT,EVNTDT,LOCIEN,OUTLOC,HIST,FDA,FNUM,VFNEW
  1.  N LEYE,REYE,PUPIL
  1.  S RET="",FNUM=$$FNUM
  1.  S INP=$G(DATA(0))
  1.  S VFIEN=$P(INP,U,1)
  1.  S VFNEW='VFIEN
  1.  S LEYE=DATA(1)
  1.  S REYE=DATA(2)
  1.  S PUPIL=DATA(3)
  1.  S TYPE=1
  1.  S VIEN=+$P(INP,U,3)
  1.  I 'VIEN S RET=$$ERR^BGOUTL(1077) Q
  1.  S HIST=$P(INP,U,13)
  1.  S DFN=$P(INP,U,2)
  1.  I 'VIEN,'HIST S RET=$$ERR^BGOUTL(1002) Q
  1.  S VCAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
  1.  S:VCAT="E" HIST=1
  1.  S PROV=$P(INP,U,4)
  1.  I 'PROV,VFIEN S RET=$$ERR^BGOUTL(1027) Q
  1.  S EVNTDT=$P(INP,U,5)
  1.  S LOCIEN=$P(INP,U,6)
  1.  S OUTLOC=$P(INP,U,7)
  1.  I HIST D  Q:RET
  1.  .S RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$S($L(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
  1.  .S:RET>0 VIEN=RET,RET="",VCAT="E"
  1.  S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
  1.  Q:RET
  1.  I 'VFIEN D  Q:'VFIEN
  1.  .D VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN)
  1.  .S:RET>0 VFIEN=RET,RET=""
  1.  S FDA=$NA(FDA(FNUM,VFIEN_","))
  1.  S @FDA@(.01)=TYPE
  1.  S @FDA@(1101)=$G(DATA(4))
  1.  I $P(PUPIL,U,1)="" S $P(PUPIL,U,1)="@"
  1.  S @FDA@(1901)=$P(PUPIL,U,1)
  1.  I $P(REYE,U,1)="" S $P(REYE,U,1)="@"
  1.  S @FDA@(1902)=$P(REYE,U,1)
  1.  I $P(REYE,U,2)="" S $P(REYE,U,2)="@"
  1.  S @FDA@(1903)=$P(REYE,U,2)
  1.  I $P(REYE,U,3)="" S $P(REYE,U,3)="@"
  1.  S @FDA@(1904)=$P(REYE,U,3)
  1.  I $P(LEYE,U,1)="" S $P(LEYE,U,1)="@"
  1.  S @FDA@(1905)=$P(LEYE,U,1)
  1.  I $P(LEYE,U,2)="" S $P(LEYE,U,2)="@"
  1.  S @FDA@(1906)=$P(LEYE,U,2)
  1.  I $P(LEYE,U,3)="" S $P(LEYE,U,3)="@"
  1.  S @FDA@(1907)=$P(LEYE,U,3)
  1.  I $P(REYE,U,8)="" S $P(REYE,U,8)="@"
  1.  S @FDA@(1908)=$P(REYE,U,8)
  1.  I $P(LEYE,U,8)="" S $P(LEYE,U,8)="@"
  1.  S @FDA@(1909)=$P(LEYE,U,8)
  1.  I $P(PUPIL,U,2)="" S $P(PUPIL,U,2)="@"
  1.  S @FDA@(1913)=$P(PUPIL,U,2)
  1.  I $P(PUPIL,U,3)="" S $P(PUPIL,U,3)="@"
  1.  S @FDA@(1914)=$P(PUPIL,U,3)
  1.  I $P(REYE,U,4)="" S $P(REYE,U,4)="@"
  1.  I $P(REYE,U,5)="" S $P(REYE,U,5)=""
  1.  I $P(REYE,U,6)="" S $P(REYE,U,6)="@"
  1.  I $P(REYE,U,7)="" S $P(REYE,U,7)=""
  1.  I $P(LEYE,U,4)="" S $P(LEYE,U,4)="@"
  1.  I $P(LEYE,U,5)="" S $P(LEYE,U,5)=""
  1.  I $P(LEYE,U,6)="" S $P(LEYE,U,6)="@"
  1.  I $P(LEYE,U,7)="" S $P(LEYE,U,7)=""
  1.  S @FDA@(1915)=$P(REYE,U,4)_$P(REYE,U,5)
  1.  S @FDA@(1916)=$P(LEYE,U,4)_$P(LEYE,U,5)
  1.  S @FDA@(1917)=$P(REYE,U,6)_$P(REYE,U,7)
  1.  S @FDA@(1918)=$P(LEYE,U,6)_$P(LEYE,U,7)
  1.  I $P(PUPIL,U,4)="" S $P(PUPIL,U,4)="@"
  1.  S @FDA@(1919)=$P(PUPIL,U,4)
  1.  I $P(PUPIL,U,5)="" S $P(PUPIL,U,5)="@"
  1.  S @FDA@(1920)=$P(PUPIL,U,5)
  1.  I PROV=""!(PROV=0) S PROV=DUZ
  1.  S:PROV @FDA@(1204)="`"_PROV
  1.  I EVNTDT="" S EVNTDT="N"
  1.  S @FDA@(1201)="N"
  1.  I VFNEW D
  1.  .S @FDA@(1216)="N"
  1.  .S @FDA@(1217)="`"_DUZ
  1.  S @FDA@(1218)="N"
  1.  S @FDA@(1219)="`"_DUZ
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"E")
  1.  I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
  1.  D:'RET VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
  1.  S:'RET RET=VFIEN
  1.  Q
  1. GETFLD(ARRAY) ;Get fields and values
  1.  S ARRAY(1)="L SPHERE^Type a number between -28.00 and +16.00 (include the + or -) OR PLANO"
  1.  S ARRAY(2)="R SPHERE^Type a number between -28.00 and +16.00 (include the + or -) OR PLANO"
  1.  S ARRAY(3)="L CYL^Type a number between -9.50 AND +9.50 (include the  + or -)"
  1.  S ARRAY(4)="R CYL^Type a number between -9.50 AND +9.50 (include the  + or -)"
  1.  S ARRAY(5)="L AXIS^Type a whole number between 0 and 180"
  1.  S ARRAY(6)="R AXIS^Type a whole number between 0 and 180"
  1.  S ARRAY(7)="L PRISM H^Enter a number between .25 and 50"
  1.  S ARRAY(8)="L BASE H^Base Up=BU, Base Down=BD, BI or BO"
  1.  S ARRAY(9)="L PRISM V^Enter a number between .25 and 50"
  1.  S ARRAY(10)="L BASE V^Base Up=BU, Base Down=BD, BI or BO"
  1.  S ARRAY(11)="R PRISM H^Enter a number between .25 and 50"
  1.  S ARRAY(12)="R BASE H^Base Up=BU, Base Down=BD, BI or BO"
  1.  S ARRAY(13)="R PRISM V^Enter a number between .25 and 50"
  1.  S ARRAY(14)="R BASE V^Base Up=BU, Base Down=BD, BI or BO"
  1.  S ARRAY(15)="PD NEAR^Type a whole number between 40 and 80"
  1.  S ARRAY(16)="PD FAR^Type a whole number between 40 and 80"
  1.  S ARRAY(17)="LEFT PD^Type a whole number between 25 and 40"
  1.  S ARRAY(18)="RIGHT PD^Type a whole number between 25 and 40"
  1.  ; Return V File #
  1. FNUM() Q 9000010.04