APSPELRX ;IHS/MSC/PLS - Electronic Pharmacy Support ;20-May-2013 17:28;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1008,1009,1011,1016**;Sep 23, 2004;Build 74
EN(RX,PHARM) ;EP
I $G(RX),$G(PHARM) D
.I $$SS(RX,PHARM) D
..D BRDCAST(RX,PHARM)
.E I $$FX(PHARM) D
..D FAX(RX,PHARM)
.D PEI(RX)
Q
; Called by APSPELRX PSCRIPT RPC
; Returns prescription text
; Input: ORIFN: IEN to Order File
; RXNUM: Prescription number (external)
; Output: Array of text
PSCRIPT(DATA,ORIFN,RXNUM) ;EP
N RX,RX1
S RX=$G(^OR(100,ORIFN,4))
S RX1=$O(^PSRX("B",RXNUM,0))
S DATA=$$TMPGBL^CIAVMRPC
;I RX'=RX1 S @DATA@(1)="Incorrect information passed."
;E D
D CAPTURE^CIAUHFS("D FAXRX^APSPELRX",DATA)
Q
;
BRDCAST(RX,PHARM) ;EP
N ORIFN,RRIEN
S ORIFN=+$P($G(^PSRX(RX,"OR1")),U,2)
S RRIEN=$$VALUE^ORCSAVE2(ORIFN,"SSRREQIEN")
; Check med class
; If III-V
;I $$DEACLS^APSPES2($$DEA^APSPES2($P($G(^PSRX(RX,0)),U,6)),"345") D Q
;.D DENY^APSPES3(ORIFN,RX,"RP","RP-A new prescription for a controlled substance is being faxed.",5)
;.D FAX(RX,PHARM)
I RRIEN&($$ACT(RRIEN)'=3) D
.D ACCEPT^APSPES3(RX,ORIFN)
E D
.Q:$$DEACLS^APSPES2($$DEA^APSPES2($P($G(^PSRX(RX,0)),U,6)),"2345")
.D NEWRX^APSPES1(RX)
Q
;
ACT(IEN) ;EP-
Q +$$GET1^DIQ(9009033.91,IEN,.08,"I")
;
FAX(RX,PHARM) ;EP
N FSRV,FFNUM,FCLNAM,FDT,FJOBNM,DATA,ARY,FAXNUM,POP
S FSRV=$$GET^XPAR("ALL","APSP AUTO RX FAX SERVER PATH")
Q:'$L(FSRV)
S FFNUM=$$GET^XPAR("ALL","APSP AUTO RX FAXED FROM NUMBER")
S FCLNAM=$$GET1^DIQ(9009033.9,PHARM,.01),FCLNAM=$TR(FCLNAM," ","_")
S FCLNAM=$TR(FCLNAM,"\/:*?<>","")
S FAXNUM=$$GET1^DIQ(9009033.9,PHARM,2.2)
S FDT=$$NOW^XLFDT(),FDT=$P(FDT,".")_"Z"_$P(FDT,".",2)
S FJOBNM=RX_"Z"_FDT
D OPEN^%ZISH("APSPFAX",FSRV,FJOBNM_"+"_FCLNAM_"@"_FAXNUM_".TXT","A")
Q:POP
U IO
D FAXRX
D CLOSE^%ZISH("APSPFAX")
S ARY("REASON")="X"
S ARY("TYPE")="T"
S ARY("COM")="Faxed to: "_FCLNAM_" @ "_FAXNUM
S ARY("RX REF")=0
D UPTLOG^APSPFNC2(.DATA,RX,0,.ARY)
Q
; Write out prescription information
FAXRX ;EP
;TODO - ADD NOTE FOR CLASS III-V IF ORDER CONTAINS SSREFREQ
N DFN,PDIV,RX0,RX2,RX3,PDIV0,PSZIP,DASH
N PNM,ADDR,VA,DEASCH,HLOC,INST,PDIVZIP
N DRUG,DRUGNM,TRDNM,SIGNER
N VANUM,DEA,DXCODE,ORIFN
S RX0=^PSRX(RX,0)
S RX2=^PSRX(RX,2)
S RX3=^PSRX(RX,3)
;
S DRUG=$P(RX0,U,6)
S DRUGNM=$$GET1^DIQ(50,DRUG,.01)
S TRDNM=$$GETDTNM(DRUG)
S DEASCH=$$GET1^DIQ(50,DRUG,3)
;
S PDIV=$P(RX2,U,9)
S PDIV0=^PS(59,PDIV,0)
S PDIVZIP=$P(PDIV0,U,5)
;
S DFN=$P(RX0,U,2)
S PNM=$$GET1^DIQ(2,DFN,.01)
D PID^VADPT
D PTADD(DFN,.ADDR)
S HLOC=$P(RX0,U,5)
S INST=+$$GET1^DIQ(44,HLOC,3)
S:'INST INST=DUZ(2)
;
S SIGNER=+$P($G(^OR(100,+$P($G(^PSRX(RX,"OR1")),U,2),8,1,0)),U,5)
S DEA=$$GET1^DIQ(200,SIGNER,53.2,"I") ;DEA #
S VANUM=$$GET1^DIQ(200,SIGNER,53.3,"I") ; VA #
S DXCODE=$$GET1^DIQ(52,RX,9999999.22)
S ORIFN=+$P($G(^PSRX(RX,"OR1")),U,2)
;
S $P(DASH,"-",63)="-"
; Output Address
; Pharmacy Division Mailing Info
;W $P(PDIV0,U)
;W !,$P(PDIV0,U,7)_","_$$GET1^DIQ(5,$P(PDIV0,U,8),1)_" "_$S(PDIVZIP["-":PDIVZIP,1:$E(PDIVZIP,1,5)_$S($E(PDIVZIP,6,9)]"":"-"_$E(PDIVZIP,6,9),1:""))
;W !,$P(PDIV0,U,3)_"-"_$P(PDIV0,U,4)
; Institution Mailing Info
W $$GET1^DIQ(4,INST,.01)
W !,$$GET1^DIQ(4,INST,1.01) ;Street Address 1
W !,$$GET1^DIQ(4,INST,1.03)_", "_$$GET1^DIQ(4,INST,.02)_" "_$$GET1^DIQ(4,INST,1.04)
W !,$$GET1^DIQ(9999999.06,INST,.13)
W !!,DASH,!
; Output Patient Info
W !,"Rx for: "_PNM_" "_VA("PID")_" DOB:"_$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I"))) ;Patch 1009
W !,?8,ADDR(1)
W !,?8,ADDR(2)
W:$L(ADDR(3)) !,?8,ADDR(3)
W !,?8,ADDR(33)
W !,DASH,!
W !,DRUGNM
W:$L(TRDNM) !,"Also known as: "_TRDNM ; todo - make parameter or field to control display
W !!,"Pharmacy may choose strength(s) of drug to meet requirements of directions."
W !
D SIG(RX)
W !!," Dispense: ",$P(RX0,U,7)_" "_$P($G(^PSDRUG(DRUG,660)),U,8)
W " Pharmacy to adjust qty for # of days."
W !,"Days Supply: ",$P(RX0,U,8)
W !," Refill(s): ",$P(RX0,U,9)
W !," Issue Date: ",$$GET1^DIQ(52,RX,1)
W !," Indicator: ",$$GET1^DIQ(52,RX,9999999.21)_$S($L(DXCODE):" ("_DXCODE_")",1:"")
;W !,?8,"DOB: ",$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I"))) ;Patch 1009
W !
D PRC(RX)
W !
W !,"Signed: /ES/"_$$GET1^DIQ(200,SIGNER,.01)_" "_VANUM_$S(+DEASCH&(DEASCH<6):" "_DEA,1:"") ;DEA PRINTS FOR SCH 1-5
W:$$SUBS(RX) !!,"DISPENSE AS WRITTEN"
I $$DEACLS^APSPES2($$DEA^APSPES2($P(RX0,U,6)),"345") D
.Q:'$$VALUE^ORCSAVE2(+$P($G(^PSRX(RX,"OR1")),U,2),"SSRREQIEN") ; Must be in response to a refill request
.W !,"NOTE: This schedule III-V prescription is being faxed."
;
W:$L($G(FFNUM)) !!,"Faxed from: ",FFNUM," ON ",$$FMTE^XLFDT($$NOW^XLFDT)
Q
SS(RXIEN,PIEN) ;EP
Q:'$G(RXIEN)!'$G(PIEN) 0
N ND7,SVCL,SDT,EDT,NOW,SPI
S SPI=$$SPI^APSPES1(+$$GET1^DIQ(52,RXIEN,4,"I"))
S NOW=$$NOW^XLFDT
S ND7=$G(^APSPOPHM(PIEN,7))
S SVCL=$P($G(^APSPOPHM(PIEN,0)),U,5) ;Service Level
S SDT=$P(ND7,U)
S EDT=$P(ND7,U,2)
Q $L(SPI)&(SVCL#2)&(NOW>SDT)&(NOW<EDT)
; Called by DC^ORWDXA when unreleased order is discontinued (denied)
; Input: ORID - ^OR(100 ien
DC(ORID) ; EP -
; Send denial HL7 message
D DENY^APSPES3(ORID)
Q
; Return fax number or flag indicating a fax number is present
FX(PIEN,FLG) ;EP
Q:'$G(PIEN) 0
N FNUM
S FNUM=$$GET1^DIQ(9009033.9,PIEN,2.2)
Q $S($G(FLG):FNUM,1:''FNUM)
; Return Trade Name Synonym for given drug (if defined)
GETDTNM(DIEN) ;EP
N LP,FLG,RET
S LP=0,RET=""
S FLG=0
F S LP=$O(^PSDRUG(DIEN,1,LP)) Q:'LP!(FLG) D
.S:$P(^PSDRUG(DIEN,1,LP,0),U,3)=0 RET=$P(^(0),U),FLG=1
Q RET
; Output Provider Comments
PRC(RX) ;EP
K ^UTILITY($J,"W")
N DIWL,DIWR,DIWF,LP,X
S DIWL=0,DIWR=48,DIWF=""
S LP=0 F S LP=$O(^PSRX(RX,"PRC",LP)) Q:'LP D
.I $D(^(LP,0)) S X=^(0) D ^DIWP
I $D(^UTILITY($J,"W")) D
.W "MD Comments:"
.S LP=0 F S LP=$O(^UTILITY($J,"W",DIWL,LP)) Q:'LP W ?13,^(LP,0),!
K ^UTILITY($J,"W")
Q
; Output SIG
SIG(RX) ;EP
N LP
S LP=0 F S LP=$O(^PSRX(RX,"SIG1",LP)) Q:'LP D
.W !,^PSRX(RX,"SIG1",LP,0)
Q
; Collect patient address information
PTADD(DFN,ARY) ;EP
N VADM,VAEL,VAERR,VAPA
D 6^VADPT
S ARY(1)=VAPA(1)
S ARY(2)=VAPA(2),ARY(3)=VAPA(3),ARY(4)=""
I VAPA(2)'="",VAPA(3)="" S ARY(2)=VAPA(2),ARY(3)=ARY(4),ARY(4)=""
I VAPA(2)="",VAPA(3)'="" S ARY(2)=VAPA(3),ARY(3)=VAPA(4),ARY(4)=""
S ARY(33)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6)))
Q
; Check Substitution Flag
SUBS(RX) ;EP -
N VAL
S VAL=$$GET1^DIQ(52,RX,9999999.25,"I")
Q $S((VAL=1)!(VAL=7):1,1:0)
; Populate the Pharmacy External Interface File
PEI(RX) ; EP
N FDA,ERR,IENS
Q:'$G(RX)
S IENS="+1,"
S FDA(52.51,IENS,.01)=RX
S FDA(52.51,IENS,2)=$P(^PSRX(RX,0),U,2) ; Patient
S FDA(52.51,IENS,3)=$$NOW^XLFDT()
S FDA(52.51,IENS,4)=$P(^PSRX(RX,0),U,4) ; Provider
S FDA(52.51,IENS,8)="F"
S FDA(52.51,IENS,9)=0
S FDA(52.51,IENS,13)="E-PRESCRIBING MESSAGE"
S FDA(52.51,IENS,14)=2
D UPDATE^DIE(,"FDA",,"ERR")
Q
APSPELRX ;IHS/MSC/PLS - Electronic Pharmacy Support ;20-May-2013 17:28;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1006,1008,1009,1011,1016**;Sep 23, 2004;Build 74
EN(RX,PHARM) ;EP
+1 IF $GET(RX)
IF $GET(PHARM)
Begin DoDot:1
+2 IF $$SS(RX,PHARM)
Begin DoDot:2
+3 DO BRDCAST(RX,PHARM)
End DoDot:2
+4 IF '$TEST
IF $$FX(PHARM)
Begin DoDot:2
+5 DO FAX(RX,PHARM)
End DoDot:2
+6 DO PEI(RX)
End DoDot:1
+7 QUIT
+8 ; Called by APSPELRX PSCRIPT RPC
+9 ; Returns prescription text
+10 ; Input: ORIFN: IEN to Order File
+11 ; RXNUM: Prescription number (external)
+12 ; Output: Array of text
PSCRIPT(DATA,ORIFN,RXNUM) ;EP
+1 NEW RX,RX1
+2 SET RX=$GET(^OR(100,ORIFN,4))
+3 SET RX1=$ORDER(^PSRX("B",RXNUM,0))
+4 SET DATA=$$TMPGBL^CIAVMRPC
+5 ;I RX'=RX1 S @DATA@(1)="Incorrect information passed."
+6 ;E D
+7 DO CAPTURE^CIAUHFS("D FAXRX^APSPELRX",DATA)
+8 QUIT
+9 ;
BRDCAST(RX,PHARM) ;EP
+1 NEW ORIFN,RRIEN
+2 SET ORIFN=+$PIECE($GET(^PSRX(RX,"OR1")),U,2)
+3 SET RRIEN=$$VALUE^ORCSAVE2(ORIFN,"SSRREQIEN")
+4 ; Check med class
+5 ; If III-V
+6 ;I $$DEACLS^APSPES2($$DEA^APSPES2($P($G(^PSRX(RX,0)),U,6)),"345") D Q
+7 ;.D DENY^APSPES3(ORIFN,RX,"RP","RP-A new prescription for a controlled substance is being faxed.",5)
+8 ;.D FAX(RX,PHARM)
+9 IF RRIEN&($$ACT(RRIEN)'=3)
Begin DoDot:1
+10 DO ACCEPT^APSPES3(RX,ORIFN)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 IF $$DEACLS^APSPES2($$DEA^APSPES2($PIECE($GET(^PSRX(RX,0)),U,6)),"2345")
QUIT
+13 DO NEWRX^APSPES1(RX)
End DoDot:1
+14 QUIT
+15 ;
ACT(IEN) ;EP-
+1 QUIT +$$GET1^DIQ(9009033.91,IEN,.08,"I")
+2 ;
FAX(RX,PHARM) ;EP
+1 NEW FSRV,FFNUM,FCLNAM,FDT,FJOBNM,DATA,ARY,FAXNUM,POP
+2 SET FSRV=$$GET^XPAR("ALL","APSP AUTO RX FAX SERVER PATH")
+3 IF '$LENGTH(FSRV)
QUIT
+4 SET FFNUM=$$GET^XPAR("ALL","APSP AUTO RX FAXED FROM NUMBER")
+5 SET FCLNAM=$$GET1^DIQ(9009033.9,PHARM,.01)
SET FCLNAM=$TRANSLATE(FCLNAM," ","_")
+6 SET FCLNAM=$TRANSLATE(FCLNAM,"\/:*?<>","")
+7 SET FAXNUM=$$GET1^DIQ(9009033.9,PHARM,2.2)
+8 SET FDT=$$NOW^XLFDT()
SET FDT=$PIECE(FDT,".")_"Z"_$PIECE(FDT,".",2)
+9 SET FJOBNM=RX_"Z"_FDT
+10 DO OPEN^%ZISH("APSPFAX",FSRV,FJOBNM_"+"_FCLNAM_"@"_FAXNUM_".TXT","A")
+11 IF POP
QUIT
+12 USE IO
+13 DO FAXRX
+14 DO CLOSE^%ZISH("APSPFAX")
+15 SET ARY("REASON")="X"
+16 SET ARY("TYPE")="T"
+17 SET ARY("COM")="Faxed to: "_FCLNAM_" @ "_FAXNUM
+18 SET ARY("RX REF")=0
+19 DO UPTLOG^APSPFNC2(.DATA,RX,0,.ARY)
+20 QUIT
+21 ; Write out prescription information
FAXRX ;EP
+1 ;TODO - ADD NOTE FOR CLASS III-V IF ORDER CONTAINS SSREFREQ
+2 NEW DFN,PDIV,RX0,RX2,RX3,PDIV0,PSZIP,DASH
+3 NEW PNM,ADDR,VA,DEASCH,HLOC,INST,PDIVZIP
+4 NEW DRUG,DRUGNM,TRDNM,SIGNER
+5 NEW VANUM,DEA,DXCODE,ORIFN
+6 SET RX0=^PSRX(RX,0)
+7 SET RX2=^PSRX(RX,2)
+8 SET RX3=^PSRX(RX,3)
+9 ;
+10 SET DRUG=$PIECE(RX0,U,6)
+11 SET DRUGNM=$$GET1^DIQ(50,DRUG,.01)
+12 SET TRDNM=$$GETDTNM(DRUG)
+13 SET DEASCH=$$GET1^DIQ(50,DRUG,3)
+14 ;
+15 SET PDIV=$PIECE(RX2,U,9)
+16 SET PDIV0=^PS(59,PDIV,0)
+17 SET PDIVZIP=$PIECE(PDIV0,U,5)
+18 ;
+19 SET DFN=$PIECE(RX0,U,2)
+20 SET PNM=$$GET1^DIQ(2,DFN,.01)
+21 DO PID^VADPT
+22 DO PTADD(DFN,.ADDR)
+23 SET HLOC=$PIECE(RX0,U,5)
+24 SET INST=+$$GET1^DIQ(44,HLOC,3)
+25 IF 'INST
SET INST=DUZ(2)
+26 ;
+27 SET SIGNER=+$PIECE($GET(^OR(100,+$PIECE($GET(^PSRX(RX,"OR1")),U,2),8,1,0)),U,5)
+28 ;DEA #
SET DEA=$$GET1^DIQ(200,SIGNER,53.2,"I")
+29 ; VA #
SET VANUM=$$GET1^DIQ(200,SIGNER,53.3,"I")
+30 SET DXCODE=$$GET1^DIQ(52,RX,9999999.22)
+31 SET ORIFN=+$PIECE($GET(^PSRX(RX,"OR1")),U,2)
+32 ;
+33 SET $PIECE(DASH,"-",63)="-"
+34 ; Output Address
+35 ; Pharmacy Division Mailing Info
+36 ;W $P(PDIV0,U)
+37 ;W !,$P(PDIV0,U,7)_","_$$GET1^DIQ(5,$P(PDIV0,U,8),1)_" "_$S(PDIVZIP["-":PDIVZIP,1:$E(PDIVZIP,1,5)_$S($E(PDIVZIP,6,9)]"":"-"_$E(PDIVZIP,6,9),1:""))
+38 ;W !,$P(PDIV0,U,3)_"-"_$P(PDIV0,U,4)
+39 ; Institution Mailing Info
+40 WRITE $$GET1^DIQ(4,INST,.01)
+41 ;Street Address 1
WRITE !,$$GET1^DIQ(4,INST,1.01)
+42 WRITE !,$$GET1^DIQ(4,INST,1.03)_", "_$$GET1^DIQ(4,INST,.02)_" "_$$GET1^DIQ(4,INST,1.04)
+43 WRITE !,$$GET1^DIQ(9999999.06,INST,.13)
+44 WRITE !!,DASH,!
+45 ; Output Patient Info
+46 ;Patch 1009
WRITE !,"Rx for: "_PNM_" "_VA("PID")_" DOB:"_$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I")))
+47 WRITE !,?8,ADDR(1)
+48 WRITE !,?8,ADDR(2)
+49 IF $LENGTH(ADDR(3))
WRITE !,?8,ADDR(3)
+50 WRITE !,?8,ADDR(33)
+51 WRITE !,DASH,!
+52 WRITE !,DRUGNM
+53 ; todo - make parameter or field to control display
IF $LENGTH(TRDNM)
WRITE !,"Also known as: "_TRDNM
+54 WRITE !!,"Pharmacy may choose strength(s) of drug to meet requirements of directions."
+55 WRITE !
+56 DO SIG(RX)
+57 WRITE !!," Dispense: ",$PIECE(RX0,U,7)_" "_$PIECE($GET(^PSDRUG(DRUG,660)),U,8)
+58 WRITE " Pharmacy to adjust qty for # of days."
+59 WRITE !,"Days Supply: ",$PIECE(RX0,U,8)
+60 WRITE !," Refill(s): ",$PIECE(RX0,U,9)
+61 WRITE !," Issue Date: ",$$GET1^DIQ(52,RX,1)
+62 WRITE !," Indicator: ",$$GET1^DIQ(52,RX,9999999.21)_$SELECT($LENGTH(DXCODE):" ("_DXCODE_")",1:"")
+63 ;W !,?8,"DOB: ",$$UP^XLFSTR($$FMTE^XLFDT($$GET1^DIQ(2,DFN,.03,"I"))) ;Patch 1009
+64 WRITE !
+65 DO PRC(RX)
+66 WRITE !
+67 ;DEA PRINTS FOR SCH 1-5
WRITE !,"Signed: /ES/"_$$GET1^DIQ(200,SIGNER,.01)_" "_VANUM_$SELECT(+DEASCH&(DEASCH<6):" "_DEA,1:"")
+68 IF $$SUBS(RX)
WRITE !!,"DISPENSE AS WRITTEN"
+69 IF $$DEACLS^APSPES2($$DEA^APSPES2($PIECE(RX0,U,6)),"345")
Begin DoDot:1
+70 ; Must be in response to a refill request
IF '$$VALUE^ORCSAVE2(+$PIECE($GET(^PSRX(RX,"OR1")),U,2),"SSRREQIEN")
QUIT
+71 WRITE !,"NOTE: This schedule III-V prescription is being faxed."
End DoDot:1
+72 ;
+73 IF $LENGTH($GET(FFNUM))
WRITE !!,"Faxed from: ",FFNUM," ON ",$$FMTE^XLFDT($$NOW^XLFDT)
+74 QUIT
SS(RXIEN,PIEN) ;EP
+1 IF '$GET(RXIEN)!'$GET(PIEN)
QUIT 0
+2 NEW ND7,SVCL,SDT,EDT,NOW,SPI
+3 SET SPI=$$SPI^APSPES1(+$$GET1^DIQ(52,RXIEN,4,"I"))
+4 SET NOW=$$NOW^XLFDT
+5 SET ND7=$GET(^APSPOPHM(PIEN,7))
+6 ;Service Level
SET SVCL=$PIECE($GET(^APSPOPHM(PIEN,0)),U,5)
+7 SET SDT=$PIECE(ND7,U)
+8 SET EDT=$PIECE(ND7,U,2)
+9 QUIT $LENGTH(SPI)&(SVCL#2)&(NOW>SDT)&(NOW<EDT)
+10 ; Called by DC^ORWDXA when unreleased order is discontinued (denied)
+11 ; Input: ORID - ^OR(100 ien
DC(ORID) ; EP -
+1 ; Send denial HL7 message
+2 DO DENY^APSPES3(ORID)
+3 QUIT
+4 ; Return fax number or flag indicating a fax number is present
FX(PIEN,FLG) ;EP
+1 IF '$GET(PIEN)
QUIT 0
+2 NEW FNUM
+3 SET FNUM=$$GET1^DIQ(9009033.9,PIEN,2.2)
+4 QUIT $SELECT($GET(FLG):FNUM,1:''FNUM)
+5 ; Return Trade Name Synonym for given drug (if defined)
GETDTNM(DIEN) ;EP
+1 NEW LP,FLG,RET
+2 SET LP=0
SET RET=""
+3 SET FLG=0
+4 FOR
SET LP=$ORDER(^PSDRUG(DIEN,1,LP))
IF 'LP!(FLG)
QUIT
Begin DoDot:1
+5 IF $PIECE(^PSDRUG(DIEN,1,LP,0),U,3)=0
SET RET=$PIECE(^(0),U)
SET FLG=1
End DoDot:1
+6 QUIT RET
+7 ; Output Provider Comments
PRC(RX) ;EP
+1 KILL ^UTILITY($JOB,"W")
+2 NEW DIWL,DIWR,DIWF,LP,X
+3 SET DIWL=0
SET DIWR=48
SET DIWF=""
+4 SET LP=0
FOR
SET LP=$ORDER(^PSRX(RX,"PRC",LP))
IF 'LP
QUIT
Begin DoDot:1
+5 IF $DATA(^(LP,0))
SET X=^(0)
DO ^DIWP
End DoDot:1
+6 IF $DATA(^UTILITY($JOB,"W"))
Begin DoDot:1
+7 WRITE "MD Comments:"
+8 SET LP=0
FOR
SET LP=$ORDER(^UTILITY($JOB,"W",DIWL,LP))
IF 'LP
QUIT
WRITE ?13,^(LP,0),!
End DoDot:1
+9 KILL ^UTILITY($JOB,"W")
+10 QUIT
+11 ; Output SIG
SIG(RX) ;EP
+1 NEW LP
+2 SET LP=0
FOR
SET LP=$ORDER(^PSRX(RX,"SIG1",LP))
IF 'LP
QUIT
Begin DoDot:1
+3 WRITE !,^PSRX(RX,"SIG1",LP,0)
End DoDot:1
+4 QUIT
+5 ; Collect patient address information
PTADD(DFN,ARY) ;EP
+1 NEW VADM,VAEL,VAERR,VAPA
+2 DO 6^VADPT
+3 SET ARY(1)=VAPA(1)
+4 SET ARY(2)=VAPA(2)
SET ARY(3)=VAPA(3)
SET ARY(4)=""
+5 IF VAPA(2)'=""
IF VAPA(3)=""
SET ARY(2)=VAPA(2)
SET ARY(3)=ARY(4)
SET ARY(4)=""
+6 IF VAPA(2)=""
IF VAPA(3)'=""
SET ARY(2)=VAPA(3)
SET ARY(3)=VAPA(4)
SET ARY(4)=""
+7 SET ARY(33)=$GET(VAPA(4))_", "_$PIECE($GET(VAPA(5)),"^",2)_" "_$SELECT($GET(VAPA(11))]"":$PIECE($GET(VAPA(11)),"^",2),1:$GET(VAPA(6)))
+8 QUIT
+9 ; Check Substitution Flag
SUBS(RX) ;EP -
+1 NEW VAL
+2 SET VAL=$$GET1^DIQ(52,RX,9999999.25,"I")
+3 QUIT $SELECT((VAL=1)!(VAL=7):1,1:0)
+4 ; Populate the Pharmacy External Interface File
PEI(RX) ; EP
+1 NEW FDA,ERR,IENS
+2 IF '$GET(RX)
QUIT
+3 SET IENS="+1,"
+4 SET FDA(52.51,IENS,.01)=RX
+5 ; Patient
SET FDA(52.51,IENS,2)=$PIECE(^PSRX(RX,0),U,2)
+6 SET FDA(52.51,IENS,3)=$$NOW^XLFDT()
+7 ; Provider
SET FDA(52.51,IENS,4)=$PIECE(^PSRX(RX,0),U,4)
+8 SET FDA(52.51,IENS,8)="F"
+9 SET FDA(52.51,IENS,9)=0
+10 SET FDA(52.51,IENS,13)="E-PRESCRIBING MESSAGE"
+11 SET FDA(52.51,IENS,14)=2
+12 DO UPDATE^DIE(,"FDA",,"ERR")
+13 QUIT
