BGOVEYE1 ; IHS/MSC/MGH - V EYE GLASS RX ;26-Nov-2013 13:33;DU
;;1.1;BGO COMPONENTS;**11,12,13**;Mar 20, 2007;Build 2
;-----------------------------------------------------------------
; Validate the data entry
VAL(RET,INP) ;EP
N CODE,X
S RET=""
S CODE=$P(INP,U,1)
I CODE="" S RET="-1^Field header not sent" Q
S X=$P(INP,U,2)
I CODE="L SPHERE"!(CODE="R SPHERE") D
.D VEYE1902^AUPNVEYE
.I '$D(X) S X="-1^Type a number between -28.00 and +16.00"
I CODE="L CYL"!(CODE="R CYL") D
.D VEYE1903^AUPNVEYE
.I '$D(X) S X="-1^Type a number between -9.50 AND +9.50"
I CODE="L AXIS"!(CODE="R AXIS") D
.K:+X'=X!(X>180)!(X<0)!(X?.E1"."1N.N) X
.I '$D(X) S X="-1^Type a whole number between 0 and 180"
I CODE="L PRISM H"!(CODE="R PRISM H")!(CODE="L PRISM V")!(CODE="R PRISM V") D
.K:$L(X)>6!($L(X)<1)!(+X>50)!(+X<.25) X
.I '$D(X) S X="-1^Enter a number between .25 and 50"
I CODE="L BASE H"!(CODE="L BASE V")!(CODE="R BASE H")!(CODE="R BASE V") D
.K:X'["BU"&(X'["BD")&(X'["BI")&(X'["BO") X
.I '$D(X) S X="-1^Base Up=BU, Base Down=BD, BI or BO"
I CODE="PD NEAR"!(CODE="PD FAR") D
.K:+X'=X!(X>80)!(X<40)!(X?.E1"."1N.N) X
.I '$D(X) S X="-1^Type a whole number between 40 and 80"
I CODE="LEFT PD"!(CODE="RIGHT PD") D
.K:+X'=X!(X>40)!(X<25)!(X?.E1"."1N.N) X
.I '$D(X) S X="-1^Type a whole number between 25 and 40"
I CODE="R READING"!(CODE="L READING") D
.K:$L(X)>4!($L(X)<3)!'(X?1"."2N!(X?1N1"."2N)) X
.I $D(X) I X?1"."2N,+X<.74 K X
.I '$D(X) S CODE="Type a value between .74 AND 9.99 with decimal pt"
I '$D(X) S RET="-1^Failed validation "_CODE
E S RET=X
Q
EYERX(BGOIEN) ;Print eye-glass prescription
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
K VADM
S FNUM=$$FNUM
S ONE=$G(^AUPNVEYE(BGOIEN,0))
S EDATA=$G(^AUPNVEYE(BGOIEN,19))
;Get pt data
S PAT=$P(ONE,U,2)
Q:PAT=""
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 PROVNAME=""
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))
S RCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,3))
S RAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,4))
S RREAD=$$EXTERNAL^DILFD(FNUM,1908,,$P(EDATA,U,8))
S RPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$P(EDATA,U,15))
S RPRISMHN=+RPRISMH
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=+RPRISMV
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))
S LCYL=$$EXTERNAL^DILFD(FNUM,1903,,$P(EDATA,U,6))
S LAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$P(EDATA,U,7))
S LREAD=$$EXTERNAL^DILFD(FNUM,1909,,$P(EDATA,U,9))
S LPRISMH=$$EXTERNAL^DILFD(FNUM,1916,,$P(EDATA,U,16))
S LPRISMHN=+LPRISMH
S LPRISMHV=$S(LPRISMH["BI":"BI",LPRISMH["BO":"BO",LPRISMH["BU":"BU",LPRISMH["BD":"BD",1:"")
S LPRISMV=$$EXTERNAL^DILFD(FNUM,1918,,$P(EDATA,U,18))
S LPRISMVN=+LPRISMV
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))
S PDFAR=$$EXTERNAL^DILFD(FNUM,1914,,$P(EDATA,U,14))
S READ=$$EXTERNAL^DILFD(FNUM,1901,,$P(EDATA,U,1))
S COMMENT=$G(^AUPNVEYE(BGOIEN,11))
S $P(DASH,"-",65)="-"
S DASH2=$$STRING^BGOVEYE1
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
W !!
W !,"| "_DASH_" |"
W !,"| "_SPACE_" |"
W !,"|",?22,FAC,?67," |"
W !,"|",?22,ADDR,?67," |"
W !,"|",?20,CITY_" "_STATE_" "_ZIP,?67," |"
I ADDR2'="" W !,"|",?30,ADDR,?67," |"
W !,"| "_SPACE_" |"
W !,"| Patient: "_PATNAME,?40,"Date: "_VDATE,?67," |"
W !,"| ",?40,"Expiration: "_UNDER,?67," |"
W !,"| "_SPACE_" |"
;W !,"| "_"Spectacle Rx",?30,"Reading only? "_READ,?67," |"
W !,"| |",?4,DASH2,?66,"| |"
W !,"| |",?8,"SPHERE ",?17,"CYL",?23,"AXIS |",?31,"NEAR",?39,"| PRISM",?47,"BASE",?52,"| PRISM",?60,"BASE",?66,"| |"
W !,"| |",?28,"|",?31,"ADD",?39,"| HZ",?52,"| VT",?66,"| |"
W !,"| |",?4,DASH2,?66,"| |"
W !,"| |",?4,"OD|",?8,RSPHERE,?16,RCYL,?23,RAXIS,?28,"|",?31,RREAD,?39,"| "_RHX,?52,"| "_RVT,?66,"| |"
W !,"| |",?4,DASH2,?66,"| |"
W !,"| |",?4,"OS|",?8,LSPHERE,?16,LCYL,?23,LAXIS,?28,"|",?31,LREAD,?39,"| "_LHX,?52,"| "_LVT,?66,"| |"
W !,"| |",?4,DASH2,?66,"| |"
W !,"| "_SPACE_" |"
W !,"| "_"Pupil Distance",?68,"|"
W !,"| |",?4,DASH2,?66,"| |"
S NTXT="" I +RPD S NTXT="R PUPIL"
S FTXT="" I +LPD S FTXT="L PUPIL"
W !,"| |",?10,"NEAR ",?20,"DISTANCE",?30,NTXT,?40,FTXT,?66,"| |"
W !,"| |",?10,PDNEAR,?20,PDFAR,?30,RPD,?40,LPD,?66,"| |"
W !,"| |",?4,DASH2,?66,"| |"
W !,"| "_SPACE_" |"
W !,"| "_"Instructions",?68,"|"
S TYPE=$P(COMMENT,"~",1),COMMENT=$P(COMMENT,"~",2)
W !,"| ",?4,TYPE,?68,"|"
W !,"| "_SPACE_" |"
I COMMENT'="" D COMM(COMMENT)
;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 W !,"| ",?4,$G(^UTILITY($J,"W",0,I,0)),?68,"|"
;K ^UTILITY($J,"W")
W !,"| "_SPACE_" |"
W !,"| Provider: "_PROVNAME,?67," |"
W !,"| "_SPACE_" |"
W !,"| Sig: ___________________________",?67," |"
W !,"| "_DASH_" |"
Q
COMM(COMMENT) ;EP-
N LEFT,STR,TXT,I
S STR=$L(COMMENT)
I STR<64 D
.W !,"| ",?4,COMMENT,?68,"|"
E D
.F I=1:1 D Q:COMMENT=""
..S TXT=$E(COMMENT,1,64),COMMENT=$E(COMMENT,65,$L(COMMENT))
..W !,"| ",?4,TXT,?68,"|"
Q
PRINT(RET,DFN,BGOIEN,BGOIO) ;print RX
N ZTIU,ZTDTH,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTSK,INVDT
S ZTIO=BGOIO,ZTDTH=$H
S ZTDESC="Printout of eyeglass RX"
S (INVDT,BGOIEN)=""
S INVDT=$O(^AUPNVEYE("AA",DFN,"")) Q:INVDT="" D
.S BGOIEN=9999999
.S BGOIEN=$O(^AUPNVEYE("AA",DFN,INVDT,BGOIEN),-1)
S ZTRTN="EYERX^BGOVEYE1",ZTSAVE(BGOIEN)="",ZTSAVE(BGOIO)=""
D ^%ZTLOAD
I $D(ZTSK) S RET="0^"_" eyeglass RX copy queued to print"
E S RET="1^Task Rejected"
Q
PRINTW(ORY,BGOIEN) ; print to windows printer
N ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE
N IOM,IOSL,IOST,IOF,IOT,IOS,POP
S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORWIN=1,ORHANDLE="BGOEYE"
S ORY=$NA(^TMP(ORSUB,$J,1))
S ORHFS=$$HFS^ORWRP()
D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
I POP D Q
. I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for BGO print")
D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
N $ETRAP,$ESTACK
S $ETRAP="D ERR^ORWRP Q"
U IO
D EYERX^BGOVEYE1(BGOIEN)
D HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
Q
GETRPT(DATA,BGOIEN,BEHFLG) ;EP
S DATA=$$TMPGBL^CIAVMRPC
I '$G(BGOIEN) S @DATA@(1)="An eyeglass prescription was not selected." Q
D CAPTURE^CIAUHFS("D EYERX^BGOVEYE1(BGOIEN)",DATA,80)
S:'$D(@DATA) @DATA@(1)="No eyeglass Rx was found."
Q
LASTEYE(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get eyeglass RX
D START^ORWRP(80,"EYEB^BGOVEYE1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
Q
EYEB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build eyeglass
N ORVP,XQORNOD,ORSSTRT,ORSSTOP,IEN,INVDT
Q:'$G(ORDFN)
I $L(ORDTRNG),'$G(ALPHA) S ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OMEGA=$$NOW^XLFDT
Q:'$G(ALPHA) Q:'$G(OMEGA)
I '$P(OMEGA,".",2) S OMEGA=OMEGA_".2359"
S ORVP=ORDFN_";DPT(",XQORNOD=1,ORSSTRT(XQORNOD)=ALPHA,ORSSTOP(XQORNOD)=OMEGA
S (INVDT,IEN)=""
S INVDT=$O(^AUPNVEYE("AA",ORDFN,"")) Q:INVDT="" D
.S IEN=9999999
.S IEN=$O(^AUPNVEYE("AA",ORDFN,INVDT,IEN),-1)
I IEN="" W !,"No eyeglass RX on file"
D EYERX(IEN)
Q
FNUM() Q 9000010.04
STRING() N STR,VAL,I
S STR=""
F I=1:1:62 S STR=STR_"-"
S VAL=STR
Q VAL
BGOVEYE1 ; IHS/MSC/MGH - V EYE GLASS RX ;26-Nov-2013 13:33;DU
+1 ;;1.1;BGO COMPONENTS;**11,12,13**;Mar 20, 2007;Build 2
+2 ;-----------------------------------------------------------------
+3 ; Validate the data entry
VAL(RET,INP) ;EP
+1 NEW CODE,X
+2 SET RET=""
+3 SET CODE=$PIECE(INP,U,1)
+4 IF CODE=""
SET RET="-1^Field header not sent"
QUIT
+5 SET X=$PIECE(INP,U,2)
+6 IF CODE="L SPHERE"!(CODE="R SPHERE")
Begin DoDot:1
+7 DO VEYE1902^AUPNVEYE
+8 IF '$DATA(X)
SET X="-1^Type a number between -28.00 and +16.00"
End DoDot:1
+9 IF CODE="L CYL"!(CODE="R CYL")
Begin DoDot:1
+10 DO VEYE1903^AUPNVEYE
+11 IF '$DATA(X)
SET X="-1^Type a number between -9.50 AND +9.50"
End DoDot:1
+12 IF CODE="L AXIS"!(CODE="R AXIS")
Begin DoDot:1
+13 IF +X'=X!(X>180)!(X<0)!(X?.E1"."1N.N)
KILL X
+14 IF '$DATA(X)
SET X="-1^Type a whole number between 0 and 180"
End DoDot:1
+15 IF CODE="L PRISM H"!(CODE="R PRISM H")!(CODE="L PRISM V")!(CODE="R PRISM V")
Begin DoDot:1
+16 IF $LENGTH(X)>6!($LENGTH(X)<1)!(+X>50)!(+X<.25)
KILL X
+17 IF '$DATA(X)
SET X="-1^Enter a number between .25 and 50"
End DoDot:1
+18 IF CODE="L BASE H"!(CODE="L BASE V")!(CODE="R BASE H")!(CODE="R BASE V")
Begin DoDot:1
+19 IF X'["BU"&(X'["BD")&(X'["BI")&(X'["BO")
KILL X
+20 IF '$DATA(X)
SET X="-1^Base Up=BU, Base Down=BD, BI or BO"
End DoDot:1
+21 IF CODE="PD NEAR"!(CODE="PD FAR")
Begin DoDot:1
+22 IF +X'=X!(X>80)!(X<40)!(X?.E1"."1N.N)
KILL X
+23 IF '$DATA(X)
SET X="-1^Type a whole number between 40 and 80"
End DoDot:1
+24 IF CODE="LEFT PD"!(CODE="RIGHT PD")
Begin DoDot:1
+25 IF +X'=X!(X>40)!(X<25)!(X?.E1"."1N.N)
KILL X
+26 IF '$DATA(X)
SET X="-1^Type a whole number between 25 and 40"
End DoDot:1
+27 IF CODE="R READING"!(CODE="L READING")
Begin DoDot:1
+28 IF $LENGTH(X)>4!($LENGTH(X)<3)!'(X?1"."2N!(X?1N1"."2N))
KILL X
+29 IF $DATA(X)
IF X?1"."2N
IF +X<.74
KILL X
+30 IF '$DATA(X)
SET CODE="Type a value between .74 AND 9.99 with decimal pt"
End DoDot:1
+31 IF '$DATA(X)
SET RET="-1^Failed validation "_CODE
+32 IF '$TEST
SET RET=X
+33 QUIT
EYERX(BGOIEN) ;Print eye-glass prescription
+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 KILL VADM
+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 IF PAT=""
QUIT
+12 SET PATNAME=$$FNAME^BTIUPCC2(PAT)_" "_$$LNAME^BTIUPCC2(PAT)
+13 SET PAT=$$GET1^DIQ(2,$PIECE(ONE,U,2),.01)
+14 SET VDATE=$$GET1^DIQ(9000010,$PIECE(ONE,U,3),.01)
+15 SET PROVNAME=""
+16 SET PROV=$PIECE($GET(^AUPNVEYE(BGOIEN,12)),U,4)
+17 IF PROV'=""
SET PROVNAME=$PIECE($GET(^VA(200,PROV,20)),U,2)
+18 SET X=$$SITE^VASITE()
+19 SET INST=$PIECE(X,U,1)
+20 SET FAC=$PIECE(X,U,2)
+21 SET ADDR=$$GET1^DIQ(4,INST,1.01)
+22 SET ADDR2=$$GET1^DIQ(4,INST,1.02)
+23 SET STATE=$$GET1^DIQ(4,INST,.02)
+24 SET CITY=$$GET1^DIQ(4,INST,1.03)
+25 SET ZIP=$$GET1^DIQ(4,INST,1.04)
+26 ;Get right eye data
+27 SET RSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$PIECE(EDATA,U,2))
+28 SET RCYL=$$EXTERNAL^DILFD(FNUM,1903,,$PIECE(EDATA,U,3))
+29 SET RAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$PIECE(EDATA,U,4))
+30 SET RREAD=$$EXTERNAL^DILFD(FNUM,1908,,$PIECE(EDATA,U,8))
+31 SET RPRISMH=$$EXTERNAL^DILFD(FNUM,1915,,$PIECE(EDATA,U,15))
+32 SET RPRISMHN=+RPRISMH
+33 SET RPRISMHV=$SELECT(RPRISMH["BI":"BI",RPRISMH["BO":"BO",RPRISMH["BU":"BU",RPRISMH["BD":"BD",1:"")
+34 SET RPRISMV=$$EXTERNAL^DILFD(FNUM,1917,,$PIECE(EDATA,U,17))
+35 SET RPRISMVN=+RPRISMV
+36 SET RPRISMVV=$SELECT(RPRISMV["BI":"BI",RPRISMV["BO":"BO",RPRISMV["BU":"BU",RPRISMV["BD":"BD",1:"")
+37 SET RPD=$$EXTERNAL^DILFD(FNUM,1920,,$PIECE(EDATA,U,20))
+38 ;Get left eye data
+39 SET LSPHERE=$$EXTERNAL^DILFD(FNUM,1902,,$PIECE(EDATA,U,5))
+40 SET LCYL=$$EXTERNAL^DILFD(FNUM,1903,,$PIECE(EDATA,U,6))
+41 SET LAXIS=$$EXTERNAL^DILFD(FNUM,1904,,$PIECE(EDATA,U,7))
+42 SET LREAD=$$EXTERNAL^DILFD(FNUM,1909,,$PIECE(EDATA,U,9))
+43 SET LPRISMH=$$EXTERNAL^DILFD(FNUM,1916,,$PIECE(EDATA,U,16))
+44 SET LPRISMHN=+LPRISMH
+45 SET LPRISMHV=$SELECT(LPRISMH["BI":"BI",LPRISMH["BO":"BO",LPRISMH["BU":"BU",LPRISMH["BD":"BD",1:"")
+46 SET LPRISMV=$$EXTERNAL^DILFD(FNUM,1918,,$PIECE(EDATA,U,18))
+47 SET LPRISMVN=+LPRISMV
+48 SET LPRISMVV=$SELECT(LPRISMV["BI":"BI",LPRISMV["BO":"BO",LPRISMV["BU":"BU",LPRISMV["BD":"BD",1:"")
+49 SET LPD=$$EXTERNAL^DILFD(FNUM,1919,,$PIECE(EDATA,U,19))
+50 ;Pupil distance
+51 SET PDNEAR=$$EXTERNAL^DILFD(FNUM,1913,,$PIECE(EDATA,U,13))
+52 SET PDFAR=$$EXTERNAL^DILFD(FNUM,1914,,$PIECE(EDATA,U,14))
+53 SET READ=$$EXTERNAL^DILFD(FNUM,1901,,$PIECE(EDATA,U,1))
+54 SET COMMENT=$GET(^AUPNVEYE(BGOIEN,11))
+55 SET $PIECE(DASH,"-",65)="-"
+56 SET DASH2=$$STRING^BGOVEYE1
+57 SET $PIECE(SPACE," ",65)=" "
+58
*** ERROR ***
SET $p(SPACE2," ",63)=" "
+59 SET $PIECE(UNDER,"_",12)="_"
+60 ;Write out prescription
+61 SET LHX=LPRISMHN_LPRISMHV
+62 SET RHX=RPRISMHN_RPRISMHV
+63 SET LVT=LPRISMVN_LPRISMVV
+64 SET RVT=RPRISMVN_RPRISMVV
+65 WRITE !!
+66 WRITE !,"| "_DASH_" |"
+67 WRITE !,"| "_SPACE_" |"
+68 WRITE !,"|",?22,FAC,?67," |"
+69 WRITE !,"|",?22,ADDR,?67," |"
+70 WRITE !,"|",?20,CITY_" "_STATE_" "_ZIP,?67," |"
+71 IF ADDR2'=""
WRITE !,"|",?30,ADDR,?67," |"
+72 WRITE !,"| "_SPACE_" |"
+73 WRITE !,"| Patient: "_PATNAME,?40,"Date: "_VDATE,?67," |"
+74 WRITE !,"| ",?40,"Expiration: "_UNDER,?67," |"
+75 WRITE !,"| "_SPACE_" |"
+76 ;W !,"| "_"Spectacle Rx",?30,"Reading only? "_READ,?67," |"
+77 WRITE !,"| |",?4,DASH2,?66,"| |"
+78 WRITE !,"| |",?8,"SPHERE ",?17,"CYL",?23,"AXIS |",?31,"NEAR",?39,"| PRISM",?47,"BASE",?52,"| PRISM",?60,"BASE",?66,"| |"
+79 WRITE !,"| |",?28,"|",?31,"ADD",?39,"| HZ",?52,"| VT",?66,"| |"
+80 WRITE !,"| |",?4,DASH2,?66,"| |"
+81 WRITE !,"| |",?4,"OD|",?8,RSPHERE,?16,RCYL,?23,RAXIS,?28,"|",?31,RREAD,?39,"| "_RHX,?52,"| "_RVT,?66,"| |"
+82 WRITE !,"| |",?4,DASH2,?66,"| |"
+83 WRITE !,"| |",?4,"OS|",?8,LSPHERE,?16,LCYL,?23,LAXIS,?28,"|",?31,LREAD,?39,"| "_LHX,?52,"| "_LVT,?66,"| |"
+84 WRITE !,"| |",?4,DASH2,?66,"| |"
+85 WRITE !,"| "_SPACE_" |"
+86 WRITE !,"| "_"Pupil Distance",?68,"|"
+87 WRITE !,"| |",?4,DASH2,?66,"| |"
+88 SET NTXT=""
IF +RPD
SET NTXT="R PUPIL"
+89 SET FTXT=""
IF +LPD
SET FTXT="L PUPIL"
+90 WRITE !,"| |",?10,"NEAR ",?20,"DISTANCE",?30,NTXT,?40,FTXT,?66,"| |"
+91 WRITE !,"| |",?10,PDNEAR,?20,PDFAR,?30,RPD,?40,LPD,?66,"| |"
+92 WRITE !,"| |",?4,DASH2,?66,"| |"
+93 WRITE !,"| "_SPACE_" |"
+94 WRITE !,"| "_"Instructions",?68,"|"
+95 SET TYPE=$PIECE(COMMENT,"~",1)
SET COMMENT=$PIECE(COMMENT,"~",2)
+96 WRITE !,"| ",?4,TYPE,?68,"|"
+97 WRITE !,"| "_SPACE_" |"
+98 IF COMMENT'=""
DO COMM(COMMENT)
+99 ;K ^UTILITY($J,"W")
+100 ;S X=COMMENT,DIWL=0,DIWR=60,DIWF="" D ^DIWP
+101 ;S J=$G(^UTILITY($J,"W",0))
+102 ;F I=1:1:J W !,"| ",?4,$G(^UTILITY($J,"W",0,I,0)),?68,"|"
+103 ;K ^UTILITY($J,"W")
+104 WRITE !,"| "_SPACE_" |"
+105 WRITE !,"| Provider: "_PROVNAME,?67," |"
+106 WRITE !,"| "_SPACE_" |"
+107 WRITE !,"| Sig: ___________________________",?67," |"
+108 WRITE !,"| "_DASH_" |"
+109 QUIT
COMM(COMMENT) ;EP-
+1 NEW LEFT,STR,TXT,I
+2 SET STR=$LENGTH(COMMENT)
+3 IF STR<64
Begin DoDot:1
+4 WRITE !,"| ",?4,COMMENT,?68,"|"
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 FOR I=1:1
Begin DoDot:2
+7 SET TXT=$EXTRACT(COMMENT,1,64)
SET COMMENT=$EXTRACT(COMMENT,65,$LENGTH(COMMENT))
+8 WRITE !,"| ",?4,TXT,?68,"|"
End DoDot:2
IF COMMENT=""
QUIT
End DoDot:1
+9 QUIT
PRINT(RET,DFN,BGOIEN,BGOIO) ;print RX
+1 NEW ZTIU,ZTDTH,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTSK,INVDT
+2 SET ZTIO=BGOIO
SET ZTDTH=$HOROLOG
+3 SET ZTDESC="Printout of eyeglass RX"
+4 SET (INVDT,BGOIEN)=""
+5 SET INVDT=$ORDER(^AUPNVEYE("AA",DFN,""))
IF INVDT=""
QUIT
Begin DoDot:1
+6 SET BGOIEN=9999999
+7 SET BGOIEN=$ORDER(^AUPNVEYE("AA",DFN,INVDT,BGOIEN),-1)
End DoDot:1
+8 SET ZTRTN="EYERX^BGOVEYE1"
SET ZTSAVE(BGOIEN)=""
SET ZTSAVE(BGOIO)=""
+9 DO ^%ZTLOAD
+10 IF $DATA(ZTSK)
SET RET="0^"_" eyeglass RX copy queued to print"
+11 IF '$TEST
SET RET="1^Task Rejected"
+12 QUIT
PRINTW(ORY,BGOIEN) ; print to windows printer
+1 NEW ZTQUEUED,ORHFS,ORSUB,ORIO,ORSTATUS,ROOT,ORERR,ORWIN,ORHANDLE
+2 NEW IOM,IOSL,IOST,IOF,IOT,IOS,POP
+3 SET (ORSUB,ROOT)="ORDATA"
SET ORIO="OR WINDOWS HFS"
SET ORWIN=1
SET ORHANDLE="BGOEYE"
+4 SET ORY=$NAME(^TMP(ORSUB,$JOB,1))
+5 SET ORHFS=$$HFS^ORWRP()
+6 DO HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
+7 IF POP
Begin DoDot:1
+8 IF $DATA(ROOT)
DO SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file for BGO print")
End DoDot:1
QUIT
+9 DO IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
+10 NEW $ETRAP,$ESTACK
+11 SET $ETRAP="D ERR^ORWRP Q"
+12 USE IO
+13 DO EYERX^BGOVEYE1(BGOIEN)
+14 DO HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
+15 QUIT
GETRPT(DATA,BGOIEN,BEHFLG) ;EP
+1 SET DATA=$$TMPGBL^CIAVMRPC
+2 IF '$GET(BGOIEN)
SET @DATA@(1)="An eyeglass prescription was not selected."
QUIT
+3 DO CAPTURE^CIAUHFS("D EYERX^BGOVEYE1(BGOIEN)",DATA,80)
+4 IF '$DATA(@DATA)
SET @DATA@(1)="No eyeglass Rx was found."
+5 QUIT
LASTEYE(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get eyeglass RX
+1 DO START^ORWRP(80,"EYEB^BGOVEYE1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
+2 QUIT
EYEB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build eyeglass
+1 NEW ORVP,XQORNOD,ORSSTRT,ORSSTOP,IEN,INVDT
+2 IF '$GET(ORDFN)
QUIT
+3 IF $LENGTH(ORDTRNG)
IF '$GET(ALPHA)
SET ALPHA=$$FMADD^XLFDT(DT,-ORDTRNG)
SET OMEGA=$$NOW^XLFDT
+4 IF '$GET(ALPHA)
QUIT
IF '$GET(OMEGA)
QUIT
+5 IF '$PIECE(OMEGA,".",2)
SET OMEGA=OMEGA_".2359"
+6 SET ORVP=ORDFN_";DPT("
SET XQORNOD=1
SET ORSSTRT(XQORNOD)=ALPHA
SET ORSSTOP(XQORNOD)=OMEGA
+7 SET (INVDT,IEN)=""
+8 SET INVDT=$ORDER(^AUPNVEYE("AA",ORDFN,""))
IF INVDT=""
QUIT
Begin DoDot:1
+9 SET IEN=9999999
+10 SET IEN=$ORDER(^AUPNVEYE("AA",ORDFN,INVDT,IEN),-1)
End DoDot:1
+11 IF IEN=""
WRITE !,"No eyeglass RX on file"
+12 DO EYERX(IEN)
+13 QUIT
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
