BTIULO16 ; IHS/MSC/MGH - EYE RX OBJECT ;03-Sep-2013 12:14;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1010,1012**;NOV 04, 2004;Build 45
EYERX(DFN,TARGET) ;Print eye-glass prescription
N INVDT,BGOIEN,CNT
S (INVDT,BGOIEN)=""
K @TARGET
S CNT=0
S INVDT=$O(^AUPNVEYE("AA",DFN,""))
I INVDT="" S @TARGET@(1,0)="No eye exam on file"
E D
.S BGOIEN=9999999
.F S BGOIEN=$O(^AUPNVEYE("AA",DFN,INVDT,BGOIEN),-1) Q:BGOIEN="" D
..;I BGOIEN="" S @TARGET@(1,0)="No eye exam on file"
..D PRINT(BGOIEN)
I CNT=0 S @TARGET@(1,0)="No eye exam on file"
Q "~@"_$NA(@TARGET)
PRINT(BGOIEN) ;print out the RX
N X,J,BGODFN,ONE,EDATA,READ,PAT,FNUM,DASH,UNDER,SPACE,PROV,PROVNAME,ADDR,ADDR2,FAC
N VDATE,VIEN,EDATE,COMMENT,EYE,LSPHERE,RSPHERE,LAXIS,RAXIS,LCYL,RCYL,LPD,RPD,LREAD,RREAD
N LPRISMH,PDNEAR,PDFAR,LRPISMH,LPRISMHN,LPRISMHV,LPRISMV,LPRISMVN,LPRISMVV,RPRISMH,RPRISMHN,RPRISMV,RPRISMHV,RPRISMVN,RPRISMVV
N ZIP,DASH2,SPACE2,STATE,CITY,LHX,LVT,RHX,RVT,PATNAME,INST,X1,FTXT,NTXT,TYPE
N DIWF,DIWL,DIWR
S FNUM=$$FNUM
S ONE=$G(^AUPNVEYE(BGOIEN,0))
S EDATA=$G(^AUPNVEYE(BGOIEN,19))
;Get pt data
S PAT=$P(ONE,U,2)
S PATNAME=$$FNAME^BTIUPCC2(PAT)_" "_$$LNAME^BTIUPCC2(PAT)
S PAT=$$GET1^DIQ(2,$P(ONE,U,2),.01)
S VDATE=$$GET1^DIQ(9000010,$P(ONE,U,3),.01)
S PROV=$P($G(^AUPNVEYE(BGOIEN,12)),U,4)
I PROV'="" S PROVNAME=$P($G(^VA(200,PROV,20)),U,2)
S X=$$SITE^VASITE()
S INST=$P(X,U,1)
S FAC=$P(X,U,2)
S ADDR=$$GET1^DIQ(4,INST,1.01)
S ADDR2=$$GET1^DIQ(4,INST,1.02)
S STATE=$$GET1^DIQ(4,INST,.02)
S CITY=$$GET1^DIQ(4,INST,1.03)
S ZIP=$$GET1^DIQ(4,INST,1.04)
;Get right eye data
S RSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$P(EDATA,U,2))
I RSPHERE="" S RSPHERE=" "
S RCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,3))
I RCYL="" S RCYL=" "
S RAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,4))
I RAXIS="" S RAXIS=" "
S RREAD=$$EXTERNAL^DILFD(FNUM,1908,,$P(EDATA,U,8))
S RPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$P(EDATA,U,15))
S RPRISMHN=+RPRISMH
I RPRISMHN=0 S RPRISMHN=""
S RPRISMHV=$S(RPRISMH["BI":"BI",RPRISMH["BO":"BO",RPRISMH["BU":"BU",RPRISMH["BD":"BD",1:"")
S RPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$P(EDATA,U,17))
S RPRISMVN=+RPRISMH
I RPRISMVN=0 S RPRISMVN=""
S RPRISMVV=$S(RPRISMV["BI":"BI",RPRISMV["BO":"BO",RPRISMV["BU":"BU",RPRISMV["BD":"BD",1:"")
S RPD=$$EXTERNAL^DILFD(FNUM,1920,,$P(EDATA,U,20))
;Get left eye data
S LSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$P(EDATA,U,5))
I LSPHERE="" S LSPHERE=" "
S LCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,6))
I LCYL="" S LCYL=" "
S LAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,7))
I LAXIS="" S LAXIS=" "
S LREAD=$$EXTERNAL^DILFD(FNUM,1909,,$P(EDATA,U,9))
S LPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$P(EDATA,U,16))
S LPRISMHN=+LPRISMH
I LPRISMHN=0 S LPRISMHN=""
S LPRISMHV=$S(LPRISMH["BI":"BI",LPRISMH["BO":"BO",LPRISMH["BU":"BU",LPRISMH["BD":"BD",1:"")
S LPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$P(EDATA,U,18))
S LPRISMVN=+LPRISMV
I LPRISMVN=0 S LPRISMVN=""
S LPRISMVV=$S(LPRISMV["BI":"BI",LPRISMV["BO":"BO",LPRISMV["BU":"BU",LPRISMV["BD":"BD",1:"")
S LPD=$$EXTERNAL^DILFD(FNUM,1919,,$P(EDATA,U,19))
;Pupil distance
S PDNEAR=$$EXTERNAL^DILFD(FNUM,1913,,$P(EDATA,U,13))
I PDNEAR="" S PDNEAR=" "
S PDFAR=$$EXTERNAL^DILFD(FNUM,1914,,$P(EDATA,U,14))
I PDFAR="" S PDFAR=" "
S READ=$$EXTERNAL^DILFD(FNUM,1901,,$P(EDATA,U,1))
S COMMENT=$G(^AUPNVEYE(BGOIEN,11))
S $P(DASH,"-",65)="-"
S DASH2=$$STRING
S $P(SPACE," ",65)=" "
S $p(SPACE2," ",63)=" "
S $P(UNDER,"_",12)="_"
;Write out prescription
S LHX=LPRISMHN_LPRISMHV
S RHX=RPRISMHN_RPRISMHV
S LVT=LPRISMVN_LPRISMVV
S RVT=RPRISMVN_RPRISMVV
S CNT=CNT+1
S @TARGET@(CNT,0)=""
S CNT=CNT+1
S @TARGET@(CNT,0)=""
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)=SPACE
S CNT=CNT+1
S @TARGET@(CNT,0)=" "_FAC
S @TARGET@(CNT,0)=" "_ADDR
S CNT=CNT+1
S CNT=CNT+1
S @TARGET@(CNT,0)=" "_CITY_" "_STATE_" "_ZIP
I ADDR2'="" D
.S CNT=CNT+1
.S @TARGET@(CNT,0)=" "_ADDR2
S CNT=CNT+1
S @TARGET@(CNT,0)=SPACE
S CNT=CNT+1
S @TARGET@(CNT,0)="Patient: "_PATNAME_" Date: "_VDATE
S CNT=CNT+1
S @TARGET@(CNT,0)=" Expiration: "_UNDER
S CNT=CNT+1
S @TARGET@(CNT,0)=SPACE
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)=" SPHERE CYL AXIS NEAR PRISM PRISM"
S CNT=CNT+1
S @TARGET@(CNT,0)=" ADD HZ VT"
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)="OD "_RSPHERE_" "_RCYL_" "_RAXIS_" "_RREAD_" "_RHX_" "_RVT
W $L(@TARGET@(CNT,0))
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)="OS "_LSPHERE_" "_LCYL_" "_LAXIS_" "_LREAD_" "_LHX_" "_LVT
W $L(@TARGET@(CNT,0))
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)=""
S CNT=CNT+1
S @TARGET@(CNT,0)="Pupil Distance"
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S NTXT="" I +RPD S NTXT="R PUPIL"
S FTXT="" I +LPD S FTXT="L PUPIL"
S CNT=CNT+1
S @TARGET@(CNT,0)=" NEAR DISTANCE "_NTXT_" "_FTXT
S CNT=CNT+1
S @TARGET@(CNT,0)=" "_PDNEAR_" "_PDFAR_" "_RPD_" "_LPD
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
S CNT=CNT+1
S @TARGET@(CNT,0)=""
S CNT=CNT+1
S @TARGET@(CNT,0)="Instructions"
S TYPE=$P(COMMENT,"~",1),COMMENT=$P(COMMENT,"~",2)
S CNT=CNT+1
S @TARGET@(CNT,0)=" "_TYPE
S CNT=CNT+1
S @TARGET@(CNT,0)=""
K ^UTILITY($J,"W")
S X=COMMENT,DIWL=0,DIWR=60,DIWF="" D ^DIWP
S J=$G(^UTILITY($J,"W",0))
F I=1:1:J S CNT=CNT+1 S @TARGET@(CNT,0)=" "_$G(^UTILITY($J,"W",0,I,0))
K ^UTILITY($J,"W")
S CNT=CNT+1
S @TARGET@(CNT,0)=""
S CNT=CNT+1
S @TARGET@(CNT,0)="Provider: "_PROVNAME
S CNT=CNT+1
S @TARGET@(CNT,0)=DASH
Q
EYE(DFN,TARGET) ;print RX
FNUM() Q 9000010.04
STRING() N STR,VAL,I
S STR=""
F I=1:1:62 S STR=STR_"-"
S VAL=STR
Q VAL
BTIULO16 ; IHS/MSC/MGH - EYE RX OBJECT ;03-Sep-2013 12:14;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1010,1012**;NOV 04, 2004;Build 45
EYERX(DFN,TARGET) ;Print eye-glass prescription
+1 NEW INVDT,BGOIEN,CNT
+2 SET (INVDT,BGOIEN)=""
+3 KILL @TARGET
+4 SET CNT=0
+5 SET INVDT=$ORDER(^AUPNVEYE("AA",DFN,""))
+6 IF INVDT=""
SET @TARGET@(1,0)="No eye exam on file"
+7 IF '$TEST
Begin DoDot:1
+8 SET BGOIEN=9999999
+9 FOR
SET BGOIEN=$ORDER(^AUPNVEYE("AA",DFN,INVDT,BGOIEN),-1)
IF BGOIEN=""
QUIT
Begin DoDot:2
+10 ;I BGOIEN="" S @TARGET@(1,0)="No eye exam on file"
+11 DO PRINT(BGOIEN)
End DoDot:2
End DoDot:1
+12 IF CNT=0
SET @TARGET@(1,0)="No eye exam on file"
+13 QUIT "~@"_$NAME(@TARGET)
PRINT(BGOIEN) ;print out the RX
+1 NEW X,J,BGODFN,ONE,EDATA,READ,PAT,FNUM,DASH,UNDER,SPACE,PROV,PROVNAME,ADDR,ADDR2,FAC
+2 NEW VDATE,VIEN,EDATE,COMMENT,EYE,LSPHERE,RSPHERE,LAXIS,RAXIS,LCYL,RCYL,LPD,RPD,LREAD,RREAD
+3 NEW LPRISMH,PDNEAR,PDFAR,LRPISMH,LPRISMHN,LPRISMHV,LPRISMV,LPRISMVN,LPRISMVV,RPRISMH,RPRISMHN,RPRISMV,RPRISMHV,RPRISMVN,RPRISMVV
+4 NEW ZIP,DASH2,SPACE2,STATE,CITY,LHX,LVT,RHX,RVT,PATNAME,INST,X1,FTXT,NTXT,TYPE
+5 NEW DIWF,DIWL,DIWR
+6 SET FNUM=$$FNUM
+7 SET ONE=$GET(^AUPNVEYE(BGOIEN,0))
+8 SET EDATA=$GET(^AUPNVEYE(BGOIEN,19))
+9 ;Get pt data
+10 SET PAT=$PIECE(ONE,U,2)
+11 SET PATNAME=$$FNAME^BTIUPCC2(PAT)_" "_$$LNAME^BTIUPCC2(PAT)
+12 SET PAT=$$GET1^DIQ(2,$PIECE(ONE,U,2),.01)
+13 SET VDATE=$$GET1^DIQ(9000010,$PIECE(ONE,U,3),.01)
+14 SET PROV=$PIECE($GET(^AUPNVEYE(BGOIEN,12)),U,4)
+15 IF PROV'=""
SET PROVNAME=$PIECE($GET(^VA(200,PROV,20)),U,2)
+16 SET X=$$SITE^VASITE()
+17 SET INST=$PIECE(X,U,1)
+18 SET FAC=$PIECE(X,U,2)
+19 SET ADDR=$$GET1^DIQ(4,INST,1.01)
+20 SET ADDR2=$$GET1^DIQ(4,INST,1.02)
+21 SET STATE=$$GET1^DIQ(4,INST,.02)
+22 SET CITY=$$GET1^DIQ(4,INST,1.03)
+23 SET ZIP=$$GET1^DIQ(4,INST,1.04)
+24 ;Get right eye data
+25 SET RSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$PIECE(EDATA,U,2))
+26 IF RSPHERE=""
SET RSPHERE=" "
+27 SET RCYL=$$EXTERNAL^DILFD(FNUM,1903,,$PIECE(EDATA,U,3))
+28 IF RCYL=""
SET RCYL=" "
+29 SET RAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$PIECE(EDATA,U,4))
+30 IF RAXIS=""
SET RAXIS=" "
+31 SET RREAD=$$EXTERNAL^DILFD(FNUM,1908,,$PIECE(EDATA,U,8))
+32 SET RPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$PIECE(EDATA,U,15))
+33 SET RPRISMHN=+RPRISMH
+34 IF RPRISMHN=0
SET RPRISMHN=""
+35 SET RPRISMHV=$SELECT(RPRISMH["BI":"BI",RPRISMH["BO":"BO",RPRISMH["BU":"BU",RPRISMH["BD":"BD",1:"")
+36 SET RPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$PIECE(EDATA,U,17))
+37 SET RPRISMVN=+RPRISMH
+38 IF RPRISMVN=0
SET RPRISMVN=""
+39 SET RPRISMVV=$SELECT(RPRISMV["BI":"BI",RPRISMV["BO":"BO",RPRISMV["BU":"BU",RPRISMV["BD":"BD",1:"")
+40 SET RPD=$$EXTERNAL^DILFD(FNUM,1920,,$PIECE(EDATA,U,20))
+41 ;Get left eye data
+42 SET LSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$PIECE(EDATA,U,5))
+43 IF LSPHERE=""
SET LSPHERE=" "
+44 SET LCYL=$$EXTERNAL^DILFD(FNUM,1903,,$PIECE(EDATA,U,6))
+45 IF LCYL=""
SET LCYL=" "
+46 SET LAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$PIECE(EDATA,U,7))
+47 IF LAXIS=""
SET LAXIS=" "
+48 SET LREAD=$$EXTERNAL^DILFD(FNUM,1909,,$PIECE(EDATA,U,9))
+49 SET LPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$PIECE(EDATA,U,16))
+50 SET LPRISMHN=+LPRISMH
+51 IF LPRISMHN=0
SET LPRISMHN=""
+52 SET LPRISMHV=$SELECT(LPRISMH["BI":"BI",LPRISMH["BO":"BO",LPRISMH["BU":"BU",LPRISMH["BD":"BD",1:"")
+53 SET LPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$PIECE(EDATA,U,18))
+54 SET LPRISMVN=+LPRISMV
+55 IF LPRISMVN=0
SET LPRISMVN=""
+56 SET LPRISMVV=$SELECT(LPRISMV["BI":"BI",LPRISMV["BO":"BO",LPRISMV["BU":"BU",LPRISMV["BD":"BD",1:"")
+57 SET LPD=$$EXTERNAL^DILFD(FNUM,1919,,$PIECE(EDATA,U,19))
+58 ;Pupil distance
+59 SET PDNEAR=$$EXTERNAL^DILFD(FNUM,1913,,$PIECE(EDATA,U,13))
+60 IF PDNEAR=""
SET PDNEAR=" "
+61 SET PDFAR=$$EXTERNAL^DILFD(FNUM,1914,,$PIECE(EDATA,U,14))
+62 IF PDFAR=""
SET PDFAR=" "
+63 SET READ=$$EXTERNAL^DILFD(FNUM,1901,,$PIECE(EDATA,U,1))
+64 SET COMMENT=$GET(^AUPNVEYE(BGOIEN,11))
+65 SET $PIECE(DASH,"-",65)="-"
+66 SET DASH2=$$STRING
+67 SET $PIECE(SPACE," ",65)=" "
+68
*** ERROR ***
SET $p(SPACE2," ",63)=" "
+69 SET $PIECE(UNDER,"_",12)="_"
+70 ;Write out prescription
+71 SET LHX=LPRISMHN_LPRISMHV
+72 SET RHX=RPRISMHN_RPRISMHV
+73 SET LVT=LPRISMVN_LPRISMVV
+74 SET RVT=RPRISMVN_RPRISMVV
+75 SET CNT=CNT+1
+76 SET @TARGET@(CNT,0)=""
+77 SET CNT=CNT+1
+78 SET @TARGET@(CNT,0)=""
+79 SET CNT=CNT+1
+80 SET @TARGET@(CNT,0)=DASH
+81 SET CNT=CNT+1
+82 SET @TARGET@(CNT,0)=SPACE
+83 SET CNT=CNT+1
+84 SET @TARGET@(CNT,0)=" "_FAC
+85 SET @TARGET@(CNT,0)=" "_ADDR
+86 SET CNT=CNT+1
+87 SET CNT=CNT+1
+88 SET @TARGET@(CNT,0)=" "_CITY_" "_STATE_" "_ZIP
+89 IF ADDR2'=""
Begin DoDot:1
+90 SET CNT=CNT+1
+91 SET @TARGET@(CNT,0)=" "_ADDR2
End DoDot:1
+92 SET CNT=CNT+1
+93 SET @TARGET@(CNT,0)=SPACE
+94 SET CNT=CNT+1
+95 SET @TARGET@(CNT,0)="Patient: "_PATNAME_" Date: "_VDATE
+96 SET CNT=CNT+1
+97 SET @TARGET@(CNT,0)=" Expiration: "_UNDER
+98 SET CNT=CNT+1
+99 SET @TARGET@(CNT,0)=SPACE
+100 SET CNT=CNT+1
+101 SET @TARGET@(CNT,0)=DASH
+102 SET CNT=CNT+1
+103 SET @TARGET@(CNT,0)=" SPHERE CYL AXIS NEAR PRISM PRISM"
+104 SET CNT=CNT+1
+105 SET @TARGET@(CNT,0)=" ADD HZ VT"
+106 SET CNT=CNT+1
+107 SET @TARGET@(CNT,0)=DASH
+108 SET CNT=CNT+1
+109 SET @TARGET@(CNT,0)="OD "_RSPHERE_" "_RCYL_" "_RAXIS_" "_RREAD_" "_RHX_" "_RVT
+110 WRITE $LENGTH(@TARGET@(CNT,0))
+111 SET CNT=CNT+1
+112 SET @TARGET@(CNT,0)=DASH
+113 SET CNT=CNT+1
+114 SET @TARGET@(CNT,0)="OS "_LSPHERE_" "_LCYL_" "_LAXIS_" "_LREAD_" "_LHX_" "_LVT
+115 WRITE $LENGTH(@TARGET@(CNT,0))
+116 SET CNT=CNT+1
+117 SET @TARGET@(CNT,0)=DASH
+118 SET CNT=CNT+1
+119 SET @TARGET@(CNT,0)=""
+120 SET CNT=CNT+1
+121 SET @TARGET@(CNT,0)="Pupil Distance"
+122 SET CNT=CNT+1
+123 SET @TARGET@(CNT,0)=DASH
+124 SET NTXT=""
IF +RPD
SET NTXT="R PUPIL"
+125 SET FTXT=""
IF +LPD
SET FTXT="L PUPIL"
+126 SET CNT=CNT+1
+127 SET @TARGET@(CNT,0)=" NEAR DISTANCE "_NTXT_" "_FTXT
+128 SET CNT=CNT+1
+129 SET @TARGET@(CNT,0)=" "_PDNEAR_" "_PDFAR_" "_RPD_" "_LPD
+130 SET CNT=CNT+1
+131 SET @TARGET@(CNT,0)=DASH
+132 SET CNT=CNT+1
+133 SET @TARGET@(CNT,0)=""
+134 SET CNT=CNT+1
+135 SET @TARGET@(CNT,0)="Instructions"
+136 SET TYPE=$PIECE(COMMENT,"~",1)
SET COMMENT=$PIECE(COMMENT,"~",2)
+137 SET CNT=CNT+1
+138 SET @TARGET@(CNT,0)=" "_TYPE
+139 SET CNT=CNT+1
+140 SET @TARGET@(CNT,0)=""
+141 KILL ^UTILITY($JOB,"W")
+142 SET X=COMMENT
SET DIWL=0
SET DIWR=60
SET DIWF=""
DO ^DIWP
+143 SET J=$GET(^UTILITY($JOB,"W",0))
+144 FOR I=1:1:J
SET CNT=CNT+1
SET @TARGET@(CNT,0)=" "_$GET(^UTILITY($JOB,"W",0,I,0))
+145 KILL ^UTILITY($JOB,"W")
+146 SET CNT=CNT+1
+147 SET @TARGET@(CNT,0)=""
+148 SET CNT=CNT+1
+149 SET @TARGET@(CNT,0)="Provider: "_PROVNAME
+150 SET CNT=CNT+1
+151 SET @TARGET@(CNT,0)=DASH
+152 QUIT
EYE(DFN,TARGET) ;print RX
FNUM() QUIT 9000010.04
STRING() NEW STR,VAL,I
+1 SET STR=""
+2 FOR I=1:1:62
SET STR=STR_"-"
+3 SET VAL=STR
+4 QUIT VAL
