APSPES1 ;IHS/MSC/PLS - SureScripts HL7 interface ;01-Apr-2014 11:28;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1011,1013,1014,1016,1017**;Sep 23, 2004;Build 40
;====================================================================
;Patch 1016 added AL1 segment and RXC segment
Q
; Build NewRx HL7 segments
NEWRX(RXIEN) ;EP
N HLPM,HLST,ERR,ARY,HLECH,HLFS,APPARMS
N RX0,RX2,DFN,LN,HL1
S LN=0
S HLPM("MESSAGE TYPE")="OMP"
S HLPM("EVENT")="O09"
S HLPM("VERSION")=2.5
I '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR) D Q
.D NOTIF^APSPES4(RXIEN,"Unable to build HL7 message.","Unable to create HL7 message")
.S ARY("REASON")="X"
.S ARY("RX REF")=0
.S ARY("COM")="eRx request failed"
.S ARY("TYPE")="F"
.D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
S HLFS=HLPM("FIELD SEPARATOR")
S HLECH=HLPM("ENCODING CHARACTERS")
S HL1("ECH")=HLECH
S HL1("FS")=HLFS
S HL1("Q")=""
S HL1("VER")=HLPM("VERSION")
S RX0=^PSRX(RXIEN,0)
S RX2=^PSRX(RXIEN,2)
S DFN=$P(RX0,U,2)
;Create segments
;
D PID(DFN),ORCNW("NW",1),RXO(1),RXR,RXC,DG1,AL1
; Define sending and receiving parameters
S APPARMS("SENDING APPLICATION")="APSP RPMS"
S APPARMS("ACCEPT ACK TYPE")="AL" ;Commit ACK type
;S APPARMS("APP ACK RESPONSE")="AACK^APSPES1" ;Callback when 'application ACK' is received
S APPARMS("ACCEPT ACK RESPONSE")="CACK^APSPES1" ;Callback when 'commit ACK' is received
S APPARMS("APP ACK TYPE")="AL" ;Application ACK type
S APPARMS("QUEUE")="APSP ERX" ;Incoming QUEUE
S APPARMS("FAILURE RESPONSE")="FAILURE^APSPES4" ;Callback for transmission failures (i.e. - No 'commit ACK' received or message not sendable.
S WHO("RECEIVING APPLICATION")="SURESCRIPTS"
S WHO("FACILITY LINK NAME")="APSP EPRES"
I '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR) D
.D NOTIF^APSPES4(RXIEN,"Unable to build HL7 message.","Unable to send request")
.S ARY("REASON")="X"
.S ARY("RX REF")=0
.S ARY("COM")="eRx request failed"
.S ARY("TYPE")="F"
.D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
E D ; Update activity log
.S ARY("REASON")="X"
.S ARY("RX REF")=0
.S ARY("TYPE")="T"
.S ARY("COM")="eRx request sent to "_$$PHMINFO^APSPES2(RXIEN)
.D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
Q
;
; Build ACK response
ACKRES ;
N X S X="" Q
; MSH, MSA segments
;
Q
;
AACK ; EP - Application ACK call back - called when AA, AE or AR is received.
N DATA,RXIEN,AACK,ARY,RET
Q:'$G(HLMSGIEN)
S RXIEN=$$RXIEN^APSPES2(HLMSGIEN)
S AACK=$G(^HLB(HLSMGIEN,4))
I $P(AACK,U,3)'["|AA|" D
.S MSG(1)="HL7 Message "_^HLB(HLMSGIEN,1)_^HLB(HLMSGIEN,2)
.S MSG(2)=" "
.S MSG(3)="did not receive a valid NEWRX acknowledgement."
.S MSG(4)=AACK
.S WHO("G.APSP EPRESCRIBING")=""
.D BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
E D
.Q:'RXIEN
.S ARY("REASON")="X"
.S ARY("RX REF")=0
.S ARY("TYPE")="U"
.S ARY("COM")="eRx update: Received acknowledgement from SureScripts"
.D UPTLOG^APSPFNC2(.RET,+RXIEN,0,.ARY)
Q
;
CACK ; EP - Commit ACK callback - called when CA, CE or CR is received.
N CACK
S CACK=$G(^HLB(HLMSGIEN,4))
I $P(CACK,"^",3)'["|CA|" D
.S MSG(1)="HL7 Message "_^HLB(HLMSGIEN,1)_^HLB(HLMSGIEN,2)
.S MSG(2)=" "
.S MSG(3)="did not receive a valid NEWRX acknowledgement."
.S MSG(4)=CACK
.S WHO("G.APSP EPRESCRIBING")=""
.D BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
Q
;
ARSP ; EP - callback for ORP/O10 event
N AACK,MSG,WHO,OPRV,ARY,RET,RXIEN,DATA,HLMSTATE,MSA
N SEGIEN,SEGMSA,MSGIEN,SEGERR,ERRTXT,TXT
S MSGIEN=0,TXT=0
D PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
S SEGIEN=$$FSEGIEN(.DATA,"MSA")
I 'SEGIEN D Q
.D BADORP^APSPES4
M SEGMSA=DATA(SEGIEN)
S MSGIEN=+$P($$GET^HLOPRS(.SEGMSA,2)," ",2)
S AACK=$$GET^HLOPRS(.SEGMSA,1)
S TXT=$$GET^HLOPRS(.SEGMSA,3)
I AACK'="AA" D
.S SEGIEN=$$FSEGIEN(.DATA,"ERR")
.M SEGERR=DATA(SEGIEN)
.S ERRTXT=$$GET^HLOPRS(.SEGERR,8)
S RXIEN=$$RXIEN^APSPES2(MSGIEN)
S OPRV=$$OPRV^APSPES2(MSGIEN)
S ARY("REASON")="X"
S ARY("RX REF")=0
S ARY("USER")=OPRV
I AACK'="AA" D Q
.D BADORP^APSPES4
.I RXIEN D
..S ARY("TYPE")="F"
..S ARY("COM")=$S($L($G(ERRTXT)):ERRTXT,1:"ERROR: eRx did not transmit.")
..D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
..D NOTIF^APSPES4(RXIEN,"ERROR: eRx did not transmit.",$S($L($G(ERRTXT)):ERRTXT,1:"Transmission was not accepted"))
Q:'RXIEN
S ARY("TYPE")="U"
S ARY("COM")=$S(TXT'="":TXT,1:"eRx update: Prescription delivered to pharmacy.")
D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
Q
ARSPRE ;Refill request call back for ERROR
D ARSP
Q
;
ERR ;
Q
; Create MSH segment
MSH(ARY) ;EP
Q
; Create PID segment
PID(DFN) ;EP
Q:'$G(DFN)
N PID,SGM,X,LP,VAL,FLD,HLQ,SSN
S HLQ=""
S PID=$$EN^VAFHLPID(DFN,"3,5,7,8,11P,13,19,",1)
D SET(.ARY,"PID",0)
D SET(.ARY,$$HRCNF^BDGF2(DFN,DUZ(2)),3,1) ; Patient HRN
D SET(.ARY,"MR",3,5) ; Medical Record
S FLD=$P(PID,HLFS,6) ; Patient Name
F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
.D SET(.ARY,VAL,5,LP)
D SET(.ARY,$P(PID,HLFS,8),7) ; Date of Birth
D SET(.ARY,$P(PID,HLFS,9),8) ; Gender
S FLD=$P(PID,HLFS,12) ; Patient Address
F LP=1:1:$L(FLD,$E(HLECH)) S VAL=$P(FLD,$E(HLECH),LP) D
.D SET(.ARY,VAL,11,LP)
;IHS/MSC/PLS - 10/25/2013
S SSN=$P(PID,HLFS,20)
I SSN="" D
.N NOSSNR
.S NOSSNR=$$GET1^DIQ(9000001,DFN,.24,"I")
.I NOSSNR S SSN=NOSSNR_"0000000"
D SET(.ARY,SSN,19) ; Patient SSN
S X=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create ORC segment
ORCNW(OCC,ADD) ;EP
N ORC,INST,NM,LP,VAL,IMMSUP,IMMNPI,ORDER,RRIEN,SSNUM,HLO,HLOIEN,HLB7
S ADD=$G(ADD,1)
D SET(.ARY,"ORC",0)
D SET(.ARY,OCC,1)
D SET(.ARY,RXIEN,2,1)
D SET(.ARY,"OP7.0",2,2)
D SET(.ARY,"D"_$P(RX0,U,8),7,3) ;Days Supply
D ORC7
D SET(.ARY,$$HLDATE^HLFNC($P(RX0,U,13),"DT"),9) ;Issue Date
D SET(.ARY,+$P(RX0,U,16),10,1) ;Entered By IEN
S NM=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(RX0,U,16),.01),HLECH)
F LP=1:1:$L(NM,$E(HLECH)) S VAL=$P(NM,$E(HLECH),LP) D
.D SET(.ARY,VAL,10,LP+1)
S IMMSUP=$$GET1^DIQ(49,$$GET1^DIQ(200,+$P(RX0,U,4),29,"I"),2,"I")
S IMMNPI=$$GET1^DIQ(200,+IMMSUP,41.99) ; Immediate Supervisor NPI
D SET(.ARY,IMMNPI,11)
S NM=$$HLNAME^HLFNC($$GET1^DIQ(200,IMMSUP,.01),HLECH)
F LP=1:1:$L(NM,$E(HLECH)) S VAL=$P(NM,$E(HLECH),LP) D
.D SET(.ARY,VAL,11,LP+1) ;Immediate Supervisor (Chief of service)
D SET(.ARY,$$SPI(+$P(RX0,U,4)),12)
S NM=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(RX0,U,4),.01),HLECH)
F LP=1:1:$L(NM,$E(HLECH)) S VAL=$P(NM,$E(HLECH),LP) D
.D SET(.ARY,VAL,12,LP+1) ;Provider
D SET(.ARY,$$PRVDEA^APSPES9(+$P(RX0,U,4)),12,10) ; DEA
D SET(.ARY,+$P(RX0,U,5),13,1)
D SET(.ARY,$$GET1^DIQ(44,+$P(RX0,U,5),.01),13,2) ;Clinic
D SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(44,+$P(RX0,U,5),99)),14) ;Clinic Phone
D SET(.ARY,$$HLDATE^HLFNC($P(RX2,U,13),"DT"),15) ;Fill Date
D:ADD SET(.ARY,"NW",16)
S INST=+$$GETRINST($P(RX2,U,9))
S:'INST INST=+$G(DUZ(2))
D SET(.ARY,$$GET1^DIQ(4,INST,.01),21) ; Institution Name
D SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(9999999.06,INST,.13)),23,1)
D SET(.ARY,"WPN",23,2)
D SET(.ARY,"PH",23,3)
D SET(.ARY,$$GET1^DIQ(4,INST,1.01),24,1) ; Institution Address 1
D SET(.ARY,$$GET1^DIQ(4,INST,1.02),24,2) ; Institution Address 2
D SET(.ARY,$$GET1^DIQ(4,INST,1.03),24,3) ; Institution City
D SET(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(4,INST,.02,"I"),1),24,4) ; Institution State Abbreviation
D SET(.ARY,$E($$GET1^DIQ(4,INST,1.04,"I"),1,5),24,5) ; Institution 5 digit Zip Code
;Code added to return Surescripts number if a new order following a deny
S ORDER=$$GET1^DIQ(52,RXIEN,39.3)
S RRIEN=$$VALUE^ORCSAVE2(ORDER,"SSRREQIEN")
I +RRIEN D
.S HLB7=""
.S SSNUM=$$GET1^DIQ(9009033.91,RRIEN,.1)
.S HLO=$$GET1^DIQ(9009033.91,RRIEN,.01) ;Message ID
.S HLOIEN=$O(^HLB("B",HLO,""))
.I +HLOIEN S HLB7=$P($G(^HLB(HLOIEN,0)),U,7)
.D SET(.ARY,SSNUM,3,1)
.D SET(.ARY,HLB7,3,2)
S:ADD ORC=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; ORC-7 Dosing Support
ORC7 ;
N LP,D,DU,CMP,CONJ
S LP=0,CMP=1 F S LP=$O(^PSRX(RXIEN,6,LP)) Q:'LP D
.S D=^PSRX(RXIEN,6,LP,0)
.S CMP=CMP+1
.S DU=$$DRGUNITS($P(RX0,U,6))
.D SET(.ARY,DU,7,1,1,CMP) ; Drug Units
.;D SET(.ARY,$P(D,U),7,1,2,CMP) ;
.D SET(.ARY,$P(D,U,8),7,2,,CMP) ; Interval
.D SET(.ARY,$$ADJDUR($P(D,U,5)),7,3,,CMP) ; Duration
.D SET(.ARY,"R",7,6,,CMP) ; Priority
.D SET(.ARY,$P(D,U),7,8,1,CMP) ; Text
.S CONJ=$P(D,U,6)
.S CONJ=$S(CONJ="T":"S",1:"A")
.D SET(.ARY,CONJ,7,9,1,CMP)
.;D SET(.ARY,"S",7,9,1,CMP) ; Conjunction
Q
; Create ORC Refill Request segment
; Input: IORC = Incoming ORC segment
ORCRF(IORC) ;EP
N ORC
D SET(.ARY,"ORC",0)
D SET(.ARY,"DF",1)
D SET(.ARY,"AF",16,1)
D SET(.ARY,"Patient should contact provider first",16,2)
D SET(.ARY,"NCPDP1131",16,3)
S ORC=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create RXO segment
RXO(ADD) ;EP
N DSF,PHM,DNAME,X,FRM,DRG,NDC,RXNORM,DIEN,TYP,NIEN,TTY,APP,FOUND
S TYP=""
D SET(.ARY,"RXO",0)
S NDC=$TR($P(RX2,U,7),"-","")
S DIEN=$P(RX0,U,6)
D SET(.ARY,NDC,1,1) ; NDC Value
;IHS/MSC/MGH Patch 1016 change to use long name if available
S DNAME=$P($G(^PSDRUG($P(RX0,U,6),999999935)),U,2)
I DNAME="" S DNAME=$$GET1^DIQ(50,$P(RX0,U,6),.01)
D SET(.ARY,DNAME,1,2) ; Drug Name
I +NDC D SET(.ARY,"NDC",1,3) ; Coding System
S DSF=$$GET1^DIQ(50.7,$$GET1^DIQ(52,RXIEN,39.2,"I"),.02,"I") ; Dosage Form IEN
S FRM=""
S X=$$GDFORM(DSF,1)
I +X S FRM=$$GET1^DIQ(9009033.7,X,3)
D SET(.ARY,FRM,5,1) ; Dosage Form Code
D SET(.ARY,$$GDFMTXT(DSF),5,2) ; Dosage Form Code Text
D SET(.ARY,"X12DE1330",5,3) ; Dosage Form Coding System
D SET(.ARY,$$GETPRC(),6,2) ; Provider Comments
D SET(.ARY,$$GETSIG(),7,2) ; SIG
D SET(.ARY,$$SUBST(RXIEN),9) ; Substitution (Default to allow) N=Not authorized, G=Allowed Generic, T=Allow therapeutic
D SET(.ARY,$P(RX0,U,7),11) ; Quantity
S DRG=$P(RX0,U,6)
D SET(.ARY,$$QTYQUAL(DRG),12,1) ; Quantity Qualifier
D SET(.ARY,$$QTYTXT(DRG),12,2) ; Quantity Qualifier Code Text
D SET(.ARY,"X12DE0335",12,3) ; Quantity Qualifier Code List
D SET(.ARY,+$P(RX0,U,9),13) ; Number of refills
D SET(.ARY,"",18) ; Strength ;
D SET(.ARY,$$SUNITS(),19) ; Strength Units
;IHS/MGH/MGH added supplies and compounds patch 1016
I $P($G(^PSDRUG(DIEN,999999935)),U,1)=1 S TYP="C"
I $E($P($G(^PSDRUG(DIEN,0)),U,2),1,2)="XA"!($P($G(^PSDRUG(DIEN,0)),U,3)["S") S TYP="P"
D SET(.ARY,TYP,27,1) ;Supply or compound code
;Patch 1017 Get Rxnorm and TTY from the NDC of the prescription
I NDC'="" D
.S RXNORM=$$RXNORM^APSPFNC1(NDC,1)
.Q:RXNORM=""
.S TTY=$P(RXNORM,U,2)
.S RXNORM=$P(RXNORM,U,1)
.D SET(.ARY,RXNORM,24,1) ;RxNorm as alt id
.S TTY=$S(TTY="GPCK":"GPK",TTY="BPCK":"BPK",1:TTY)
.D SET(.ARY,TTY,24,2) ;TTY code
.D SET(.ARY,"RXNORM",24,3) ;Code List
S PHM=$$GPHM(RXIEN)
I PHM D
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.02),32,1) ; Pharmacy NCPDP Provider ID
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.01),32,2) ; Pharmacy Name
.D SET(.ARY,"D3",32,3) ; Pharmacy NCPDP Provider ID
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.04),32,4) ; Pharmacy NPI
.D SET(.ARY,"HPI",32,6)
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.1),33,1) ; Pharmacy Address
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.2),33,2) ; Address second line
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.3),33,3) ; Pharmacy City
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.4),33,4) ; State
.D SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.5),33,5) ; Zip
.D SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1)),36,1) ; Telephone
.D SET(.ARY,"WPN",36,2) ; Work Phone
.D SET(.ARY,"PH",36,3) ; Phone
.S:ADD PHM=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create RXR segment
RXR ;EP
D RXR^APSPES4
Q
RXC ; Create RXC segment
D RXC^APSPES4
Q
; Create DG1 segment
DG1 ;EP -
D DG1^APSPES4
Q
; Create AL1 segment
AL1 ;EP -
D AL1^APSPES4
Q
; Create MSA segment
MSA ;EP
N MSA
D SET(.ARY,"MSA",0)
D SET(.ARY,"AA",1)
D SET(.ARY,"TODO-MSGID",2)
D SET(.ARY,"Transaction Successful",3)
D SET(.ARY,"todo-010",4)
S MSA=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create MSH segment
;EP
N MSH
D SET(.ARY,"MSH",0)
S MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
; Return Related Institution for prescription
; Input: Pharmacy Division IEN
; Output: Institution Pointer (File 4)
GETRINST(PDIV) ;EP
Q $$GET1^DIQ(59,PDIV,100,"I")
; Return NCPDP Route
GROUTE(RIEN) ;EP
N RXROUTE
S RXROUTE=$$GET1^DIQ(51.2,RIEN,.01)
Q RXROUTE
; Return NCPDP Dosage Form Code
; Input: FORM = IEN to Dosage Form File
; TYPE = 0(default) returns code; 1 returns IEN
GDFORM(FORM,TYPE) ;EP
Q $$GET1^DIQ(50.606,FORM,9999999.01,$S($G(TYPE):"I",1:"E"))
; Return NCPDP Dosage Form Code Text
GDFMTXT(FORM) ;EP
Q $$GET1^DIQ(9009033.7,$$GDFORM(FORM,1),1)
; Return NCPDP Quantity Qualifier mapped to Dispense Unit NCPDP Code field in File 50
; Input: DIEN- IEN to Drug File (50)
; Output: Returns .01 field value from APSP NCPDP Control Codes file
QTYQUAL(DIEN) ;EP
N X,RET
S RET=""
S X=$$GET1^DIQ(50,DIEN,9999999.145,"I")
I +X S RET=$$GET1^DIQ(9009033.7,X,3)
Q RET
QTYTXT(DIEN) ;EP
N X,RET
S RET=""
S X=$$GET1^DIQ(50,DIEN,9999999.145,"I")
I +X S RET=$$GET1^DIQ(9009033.7,X,1)
Q RET
; Return Pharmacy IEN
GPHM(RXIEN) ;EP
Q $P($G(^PSRX(RXIEN,999999921)),U,4)
; Return Unit from Drug File
DRGUNITS(DIEN) ;EP
Q $$GET1^DIQ(50,DIEN,902)
; Return NCPDP Units
SUNITS() ;EP
Q ""
; Return adjusted Duration Value
ADJDUR(VAL) ;
N N,D
Q:'VAL "INDEF"
S N=$E(VAL,1,$L(VAL)-1)
S D=$E(VAL,$L(VAL))
Q D_N
; Find and return prepared segment array
PREPARY(SRC,SEG,RET,START) ;
N IEN,LP
S IEN=$$FSEGIEN(.SRC,SEG,.START)
Q:'IEN
S LP=0 F S LP=$O(SRC(IEN,LP)) Q:'LP D
.M RET(LP-1)=SRC(IEN,LP)
Q
; Return IEN to particular segment in source array
; Optional START value can specify where in source to start search
FSEGIEN(SRC,SEG,START) ;
N LP,RES
S (LP,RES)=0
S:$G(START) LP=START
F S LP=$O(SRC(LP)) Q:'LP D Q:RES
.I $G(SRC(LP,"SEGMENT TYPE"))=SEG S RES=LP
Q RES
; Return SIG as a single string
GETSIG() ;EP
N LP,RET
S RET=""
S LP=0 F S LP=$O(^PSRX(RXIEN,"SIG1",LP)) Q:'LP D
.S RET=RET_^PSRX(RXIEN,"SIG1",LP,0)
Q RET
; Return Provider Comments as a single string
GETPRC() ;EP -
N LP,RET
S RET=""
S LP=0 F S LP=$O(^PSRX(RXIEN,"PRC",LP)) Q:'LP D
.S RET=RET_^PSRX(RXIEN,"PRC",LP,0)
Q RET
; Return SPI number for user
SPI(USR) ; EP -
Q $$GET1^DIQ(200,USR,43.99)
; Return HL7 substitution value
SUBST(RXIEN) ; EP -
N VAL
S VAL=$$GET1^DIQ(52,RXIEN,9999999.25,"I")
Q $S(VAL=1!(VAL=7):"N",1:"G")
APSPES1 ;IHS/MSC/PLS - SureScripts HL7 interface ;01-Apr-2014 11:28;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1009,1011,1013,1014,1016,1017**;Sep 23, 2004;Build 40
+2 ;====================================================================
+3 ;Patch 1016 added AL1 segment and RXC segment
+4 QUIT
+5 ; Build NewRx HL7 segments
NEWRX(RXIEN) ;EP
+1 NEW HLPM,HLST,ERR,ARY,HLECH,HLFS,APPARMS
+2 NEW RX0,RX2,DFN,LN,HL1
+3 SET LN=0
+4 SET HLPM("MESSAGE TYPE")="OMP"
+5 SET HLPM("EVENT")="O09"
+6 SET HLPM("VERSION")=2.5
+7 IF '$$NEWMSG^HLOAPI(.HLPM,.HLST,.ERR)
Begin DoDot:1
+8 DO NOTIF^APSPES4(RXIEN,"Unable to build HL7 message.","Unable to create HL7 message")
+9 SET ARY("REASON")="X"
+10 SET ARY("RX REF")=0
+11 SET ARY("COM")="eRx request failed"
+12 SET ARY("TYPE")="F"
+13 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
End DoDot:1
QUIT
+14 SET HLFS=HLPM("FIELD SEPARATOR")
+15 SET HLECH=HLPM("ENCODING CHARACTERS")
+16 SET HL1("ECH")=HLECH
+17 SET HL1("FS")=HLFS
+18 SET HL1("Q")=""
+19 SET HL1("VER")=HLPM("VERSION")
+20 SET RX0=^PSRX(RXIEN,0)
+21 SET RX2=^PSRX(RXIEN,2)
+22 SET DFN=$PIECE(RX0,U,2)
+23 ;Create segments
+24 ;
+25 DO PID(DFN)
DO ORCNW("NW",1)
DO RXO(1)
DO RXR
DO RXC
DO DG1
DO AL1
+26 ; Define sending and receiving parameters
+27 SET APPARMS("SENDING APPLICATION")="APSP RPMS"
+28 ;Commit ACK type
SET APPARMS("ACCEPT ACK TYPE")="AL"
+29 ;S APPARMS("APP ACK RESPONSE")="AACK^APSPES1" ;Callback when 'application ACK' is received
+30 ;Callback when 'commit ACK' is received
SET APPARMS("ACCEPT ACK RESPONSE")="CACK^APSPES1"
+31 ;Application ACK type
SET APPARMS("APP ACK TYPE")="AL"
+32 ;Incoming QUEUE
SET APPARMS("QUEUE")="APSP ERX"
+33 ;Callback for transmission failures (i.e. - No 'commit ACK' received or message not sendable.
SET APPARMS("FAILURE RESPONSE")="FAILURE^APSPES4"
+34 SET WHO("RECEIVING APPLICATION")="SURESCRIPTS"
+35 SET WHO("FACILITY LINK NAME")="APSP EPRES"
+36 IF '$$SENDONE^HLOAPI1(.HLST,.APPARMS,.WHO,.ERR)
Begin DoDot:1
+37 DO NOTIF^APSPES4(RXIEN,"Unable to build HL7 message.","Unable to send request")
+38 SET ARY("REASON")="X"
+39 SET ARY("RX REF")=0
+40 SET ARY("COM")="eRx request failed"
+41 SET ARY("TYPE")="F"
+42 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
End DoDot:1
+43 ; Update activity log
IF '$TEST
Begin DoDot:1
+44 SET ARY("REASON")="X"
+45 SET ARY("RX REF")=0
+46 SET ARY("TYPE")="T"
+47 SET ARY("COM")="eRx request sent to "_$$PHMINFO^APSPES2(RXIEN)
+48 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
End DoDot:1
+49 QUIT
+50 ;
+51 ; Build ACK response
ACKRES ;
+1 NEW X
SET X=""
QUIT
+2 ; MSH, MSA segments
+3 ;
+4 QUIT
+5 ;
AACK ; EP - Application ACK call back - called when AA, AE or AR is received.
+1 NEW DATA,RXIEN,AACK,ARY,RET
+2 IF '$GET(HLMSGIEN)
QUIT
+3 SET RXIEN=$$RXIEN^APSPES2(HLMSGIEN)
+4 SET AACK=$GET(^HLB(HLSMGIEN,4))
+5 IF $PIECE(AACK,U,3)'["|AA|"
Begin DoDot:1
+6 SET MSG(1)="HL7 Message "_^HLB(HLMSGIEN,1)_^HLB(HLMSGIEN,2)
+7 SET MSG(2)=" "
+8 SET MSG(3)="did not receive a valid NEWRX acknowledgement."
+9 SET MSG(4)=AACK
+10 SET WHO("G.APSP EPRESCRIBING")=""
+11 DO BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 IF 'RXIEN
QUIT
+14 SET ARY("REASON")="X"
+15 SET ARY("RX REF")=0
+16 SET ARY("TYPE")="U"
+17 SET ARY("COM")="eRx update: Received acknowledgement from SureScripts"
+18 DO UPTLOG^APSPFNC2(.RET,+RXIEN,0,.ARY)
End DoDot:1
+19 QUIT
+20 ;
CACK ; EP - Commit ACK callback - called when CA, CE or CR is received.
+1 NEW CACK
+2 SET CACK=$GET(^HLB(HLMSGIEN,4))
+3 IF $PIECE(CACK,"^",3)'["|CA|"
Begin DoDot:1
+4 SET MSG(1)="HL7 Message "_^HLB(HLMSGIEN,1)_^HLB(HLMSGIEN,2)
+5 SET MSG(2)=" "
+6 SET MSG(3)="did not receive a valid NEWRX acknowledgement."
+7 SET MSG(4)=CACK
+8 SET WHO("G.APSP EPRESCRIBING")=""
+9 DO BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
End DoDot:1
+10 QUIT
+11 ;
ARSP ; EP - callback for ORP/O10 event
+1 NEW AACK,MSG,WHO,OPRV,ARY,RET,RXIEN,DATA,HLMSTATE,MSA
+2 NEW SEGIEN,SEGMSA,MSGIEN,SEGERR,ERRTXT,TXT
+3 SET MSGIEN=0
SET TXT=0
+4 DO PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
+5 SET SEGIEN=$$FSEGIEN(.DATA,"MSA")
+6 IF 'SEGIEN
Begin DoDot:1
+7 DO BADORP^APSPES4
End DoDot:1
QUIT
+8 MERGE SEGMSA=DATA(SEGIEN)
+9 SET MSGIEN=+$PIECE($$GET^HLOPRS(.SEGMSA,2)," ",2)
+10 SET AACK=$$GET^HLOPRS(.SEGMSA,1)
+11 SET TXT=$$GET^HLOPRS(.SEGMSA,3)
+12 IF AACK'="AA"
Begin DoDot:1
+13 SET SEGIEN=$$FSEGIEN(.DATA,"ERR")
+14 MERGE SEGERR=DATA(SEGIEN)
+15 SET ERRTXT=$$GET^HLOPRS(.SEGERR,8)
End DoDot:1
+16 SET RXIEN=$$RXIEN^APSPES2(MSGIEN)
+17 SET OPRV=$$OPRV^APSPES2(MSGIEN)
+18 SET ARY("REASON")="X"
+19 SET ARY("RX REF")=0
+20 SET ARY("USER")=OPRV
+21 IF AACK'="AA"
Begin DoDot:1
+22 DO BADORP^APSPES4
+23 IF RXIEN
Begin DoDot:2
+24 SET ARY("TYPE")="F"
+25 SET ARY("COM")=$SELECT($LENGTH($GET(ERRTXT)):ERRTXT,1:"ERROR: eRx did not transmit.")
+26 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
+27 DO NOTIF^APSPES4(RXIEN,"ERROR: eRx did not transmit.",$SELECT($LENGTH($GET(ERRTXT)):ERRTXT,1:"Transmission was not accepted"))
End DoDot:2
End DoDot:1
QUIT
+28 IF 'RXIEN
QUIT
+29 SET ARY("TYPE")="U"
+30 SET ARY("COM")=$SELECT(TXT'="":TXT,1:"eRx update: Prescription delivered to pharmacy.")
+31 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
+32 QUIT
ARSPRE ;Refill request call back for ERROR
+1 DO ARSP
+2 QUIT
+3 ;
ERR ;
+1 QUIT
+2 ; Create MSH segment
MSH(ARY) ;EP
+1 QUIT
+2 ; Create PID segment
PID(DFN) ;EP
+1 IF '$GET(DFN)
QUIT
+2 NEW PID,SGM,X,LP,VAL,FLD,HLQ,SSN
+3 SET HLQ=""
+4 SET PID=$$EN^VAFHLPID(DFN,"3,5,7,8,11P,13,19,",1)
+5 DO SET(.ARY,"PID",0)
+6 ; Patient HRN
DO SET(.ARY,$$HRCNF^BDGF2(DFN,DUZ(2)),3,1)
+7 ; Medical Record
DO SET(.ARY,"MR",3,5)
+8 ; Patient Name
SET FLD=$PIECE(PID,HLFS,6)
+9 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+10 DO SET(.ARY,VAL,5,LP)
End DoDot:1
+11 ; Date of Birth
DO SET(.ARY,$PIECE(PID,HLFS,8),7)
+12 ; Gender
DO SET(.ARY,$PIECE(PID,HLFS,9),8)
+13 ; Patient Address
SET FLD=$PIECE(PID,HLFS,12)
+14 FOR LP=1:1:$LENGTH(FLD,$EXTRACT(HLECH))
SET VAL=$PIECE(FLD,$EXTRACT(HLECH),LP)
Begin DoDot:1
+15 DO SET(.ARY,VAL,11,LP)
End DoDot:1
+16 ;IHS/MSC/PLS - 10/25/2013
+17 SET SSN=$PIECE(PID,HLFS,20)
+18 IF SSN=""
Begin DoDot:1
+19 NEW NOSSNR
+20 SET NOSSNR=$$GET1^DIQ(9000001,DFN,.24,"I")
+21 IF NOSSNR
SET SSN=NOSSNR_"0000000"
End DoDot:1
+22 ; Patient SSN
DO SET(.ARY,SSN,19)
+23 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY)
+24 QUIT
+25 ; Create ORC segment
ORCNW(OCC,ADD) ;EP
+1 NEW ORC,INST,NM,LP,VAL,IMMSUP,IMMNPI,ORDER,RRIEN,SSNUM,HLO,HLOIEN,HLB7
+2 SET ADD=$GET(ADD,1)
+3 DO SET(.ARY,"ORC",0)
+4 DO SET(.ARY,OCC,1)
+5 DO SET(.ARY,RXIEN,2,1)
+6 DO SET(.ARY,"OP7.0",2,2)
+7 ;Days Supply
DO SET(.ARY,"D"_$PIECE(RX0,U,8),7,3)
+8 DO ORC7
+9 ;Issue Date
DO SET(.ARY,$$HLDATE^HLFNC($PIECE(RX0,U,13),"DT"),9)
+10 ;Entered By IEN
DO SET(.ARY,+$PIECE(RX0,U,16),10,1)
+11 SET NM=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(RX0,U,16),.01),HLECH)
+12 FOR LP=1:1:$LENGTH(NM,$EXTRACT(HLECH))
SET VAL=$PIECE(NM,$EXTRACT(HLECH),LP)
Begin DoDot:1
+13 DO SET(.ARY,VAL,10,LP+1)
End DoDot:1
+14 SET IMMSUP=$$GET1^DIQ(49,$$GET1^DIQ(200,+$PIECE(RX0,U,4),29,"I"),2,"I")
+15 ; Immediate Supervisor NPI
SET IMMNPI=$$GET1^DIQ(200,+IMMSUP,41.99)
+16 DO SET(.ARY,IMMNPI,11)
+17 SET NM=$$HLNAME^HLFNC($$GET1^DIQ(200,IMMSUP,.01),HLECH)
+18 FOR LP=1:1:$LENGTH(NM,$EXTRACT(HLECH))
SET VAL=$PIECE(NM,$EXTRACT(HLECH),LP)
Begin DoDot:1
+19 ;Immediate Supervisor (Chief of service)
DO SET(.ARY,VAL,11,LP+1)
End DoDot:1
+20 DO SET(.ARY,$$SPI(+$PIECE(RX0,U,4)),12)
+21 SET NM=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(RX0,U,4),.01),HLECH)
+22 FOR LP=1:1:$LENGTH(NM,$EXTRACT(HLECH))
SET VAL=$PIECE(NM,$EXTRACT(HLECH),LP)
Begin DoDot:1
+23 ;Provider
DO SET(.ARY,VAL,12,LP+1)
End DoDot:1
+24 ; DEA
DO SET(.ARY,$$PRVDEA^APSPES9(+$PIECE(RX0,U,4)),12,10)
+25 DO SET(.ARY,+$PIECE(RX0,U,5),13,1)
+26 ;Clinic
DO SET(.ARY,$$GET1^DIQ(44,+$PIECE(RX0,U,5),.01),13,2)
+27 ;Clinic Phone
DO SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(44,+$PIECE(RX0,U,5),99)),14)
+28 ;Fill Date
DO SET(.ARY,$$HLDATE^HLFNC($PIECE(RX2,U,13),"DT"),15)
+29 IF ADD
DO SET(.ARY,"NW",16)
+30 SET INST=+$$GETRINST($PIECE(RX2,U,9))
+31 IF 'INST
SET INST=+$GET(DUZ(2))
+32 ; Institution Name
DO SET(.ARY,$$GET1^DIQ(4,INST,.01),21)
+33 DO SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(9999999.06,INST,.13)),23,1)
+34 DO SET(.ARY,"WPN",23,2)
+35 DO SET(.ARY,"PH",23,3)
+36 ; Institution Address 1
DO SET(.ARY,$$GET1^DIQ(4,INST,1.01),24,1)
+37 ; Institution Address 2
DO SET(.ARY,$$GET1^DIQ(4,INST,1.02),24,2)
+38 ; Institution City
DO SET(.ARY,$$GET1^DIQ(4,INST,1.03),24,3)
+39 ; Institution State Abbreviation
DO SET(.ARY,$$GET1^DIQ(5,$$GET1^DIQ(4,INST,.02,"I"),1),24,4)
+40 ; Institution 5 digit Zip Code
DO SET(.ARY,$EXTRACT($$GET1^DIQ(4,INST,1.04,"I"),1,5),24,5)
+41 ;Code added to return Surescripts number if a new order following a deny
+42 SET ORDER=$$GET1^DIQ(52,RXIEN,39.3)
+43 SET RRIEN=$$VALUE^ORCSAVE2(ORDER,"SSRREQIEN")
+44 IF +RRIEN
Begin DoDot:1
+45 SET HLB7=""
+46 SET SSNUM=$$GET1^DIQ(9009033.91,RRIEN,.1)
+47 ;Message ID
SET HLO=$$GET1^DIQ(9009033.91,RRIEN,.01)
+48 SET HLOIEN=$ORDER(^HLB("B",HLO,""))
+49 IF +HLOIEN
SET HLB7=$PIECE($GET(^HLB(HLOIEN,0)),U,7)
+50 DO SET(.ARY,SSNUM,3,1)
+51 DO SET(.ARY,HLB7,3,2)
End DoDot:1
+52 IF ADD
SET ORC=$$ADDSEG^HLOAPI(.HLST,.ARY)
+53 QUIT
+54 ; ORC-7 Dosing Support
ORC7 ;
+1 NEW LP,D,DU,CMP,CONJ
+2 SET LP=0
SET CMP=1
FOR
SET LP=$ORDER(^PSRX(RXIEN,6,LP))
IF 'LP
QUIT
Begin DoDot:1
+3 SET D=^PSRX(RXIEN,6,LP,0)
+4 SET CMP=CMP+1
+5 SET DU=$$DRGUNITS($PIECE(RX0,U,6))
+6 ; Drug Units
DO SET(.ARY,DU,7,1,1,CMP)
+7 ;D SET(.ARY,$P(D,U),7,1,2,CMP) ;
+8 ; Interval
DO SET(.ARY,$PIECE(D,U,8),7,2,,CMP)
+9 ; Duration
DO SET(.ARY,$$ADJDUR($PIECE(D,U,5)),7,3,,CMP)
+10 ; Priority
DO SET(.ARY,"R",7,6,,CMP)
+11 ; Text
DO SET(.ARY,$PIECE(D,U),7,8,1,CMP)
+12 SET CONJ=$PIECE(D,U,6)
+13 SET CONJ=$SELECT(CONJ="T":"S",1:"A")
+14 DO SET(.ARY,CONJ,7,9,1,CMP)
+15 ;D SET(.ARY,"S",7,9,1,CMP) ; Conjunction
End DoDot:1
+16 QUIT
+17 ; Create ORC Refill Request segment
+18 ; Input: IORC = Incoming ORC segment
ORCRF(IORC) ;EP
+1 NEW ORC
+2 DO SET(.ARY,"ORC",0)
+3 DO SET(.ARY,"DF",1)
+4 DO SET(.ARY,"AF",16,1)
+5 DO SET(.ARY,"Patient should contact provider first",16,2)
+6 DO SET(.ARY,"NCPDP1131",16,3)
+7 SET ORC=$$ADDSEG^HLOAPI(.HLST,.ARY)
+8 QUIT
+9 ; Create RXO segment
RXO(ADD) ;EP
+1 NEW DSF,PHM,DNAME,X,FRM,DRG,NDC,RXNORM,DIEN,TYP,NIEN,TTY,APP,FOUND
+2 SET TYP=""
+3 DO SET(.ARY,"RXO",0)
+4 SET NDC=$TRANSLATE($PIECE(RX2,U,7),"-","")
+5 SET DIEN=$PIECE(RX0,U,6)
+6 ; NDC Value
DO SET(.ARY,NDC,1,1)
+7 ;IHS/MSC/MGH Patch 1016 change to use long name if available
+8 SET DNAME=$PIECE($GET(^PSDRUG($PIECE(RX0,U,6),999999935)),U,2)
+9 IF DNAME=""
SET DNAME=$$GET1^DIQ(50,$PIECE(RX0,U,6),.01)
+10 ; Drug Name
DO SET(.ARY,DNAME,1,2)
+11 ; Coding System
IF +NDC
DO SET(.ARY,"NDC",1,3)
+12 ; Dosage Form IEN
SET DSF=$$GET1^DIQ(50.7,$$GET1^DIQ(52,RXIEN,39.2,"I"),.02,"I")
+13 SET FRM=""
+14 SET X=$$GDFORM(DSF,1)
+15 IF +X
SET FRM=$$GET1^DIQ(9009033.7,X,3)
+16 ; Dosage Form Code
DO SET(.ARY,FRM,5,1)
+17 ; Dosage Form Code Text
DO SET(.ARY,$$GDFMTXT(DSF),5,2)
+18 ; Dosage Form Coding System
DO SET(.ARY,"X12DE1330",5,3)
+19 ; Provider Comments
DO SET(.ARY,$$GETPRC(),6,2)
+20 ; SIG
DO SET(.ARY,$$GETSIG(),7,2)
+21 ; Substitution (Default to allow) N=Not authorized, G=Allowed Generic, T=Allow therapeutic
DO SET(.ARY,$$SUBST(RXIEN),9)
+22 ; Quantity
DO SET(.ARY,$PIECE(RX0,U,7),11)
+23 SET DRG=$PIECE(RX0,U,6)
+24 ; Quantity Qualifier
DO SET(.ARY,$$QTYQUAL(DRG),12,1)
+25 ; Quantity Qualifier Code Text
DO SET(.ARY,$$QTYTXT(DRG),12,2)
+26 ; Quantity Qualifier Code List
DO SET(.ARY,"X12DE0335",12,3)
+27 ; Number of refills
DO SET(.ARY,+$PIECE(RX0,U,9),13)
+28 ; Strength ;
DO SET(.ARY,"",18)
+29 ; Strength Units
DO SET(.ARY,$$SUNITS(),19)
+30 ;IHS/MGH/MGH added supplies and compounds patch 1016
+31 IF $PIECE($GET(^PSDRUG(DIEN,999999935)),U,1)=1
SET TYP="C"
+32 IF $EXTRACT($PIECE($GET(^PSDRUG(DIEN,0)),U,2),1,2)="XA"!($PIECE($GET(^PSDRUG(DIEN,0)),U,3)["S")
SET TYP="P"
+33 ;Supply or compound code
DO SET(.ARY,TYP,27,1)
+34 ;Patch 1017 Get Rxnorm and TTY from the NDC of the prescription
+35 IF NDC'=""
Begin DoDot:1
+36 SET RXNORM=$$RXNORM^APSPFNC1(NDC,1)
+37 IF RXNORM=""
QUIT
+38 SET TTY=$PIECE(RXNORM,U,2)
+39 SET RXNORM=$PIECE(RXNORM,U,1)
+40 ;RxNorm as alt id
DO SET(.ARY,RXNORM,24,1)
+41 SET TTY=$SELECT(TTY="GPCK":"GPK",TTY="BPCK":"BPK",1:TTY)
+42 ;TTY code
DO SET(.ARY,TTY,24,2)
+43 ;Code List
DO SET(.ARY,"RXNORM",24,3)
End DoDot:1
+44 SET PHM=$$GPHM(RXIEN)
+45 IF PHM
Begin DoDot:1
+46 ; Pharmacy NCPDP Provider ID
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.02),32,1)
+47 ; Pharmacy Name
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.01),32,2)
+48 ; Pharmacy NCPDP Provider ID
DO SET(.ARY,"D3",32,3)
+49 ; Pharmacy NPI
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,.04),32,4)
+50 DO SET(.ARY,"HPI",32,6)
+51 ; Pharmacy Address
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.1),33,1)
+52 ; Address second line
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.2),33,2)
+53 ; Pharmacy City
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.3),33,3)
+54 ; State
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.4),33,4)
+55 ; Zip
DO SET(.ARY,$$GET1^DIQ(9009033.9,PHM,1.5),33,5)
+56 ; Telephone
DO SET(.ARY,$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1)),36,1)
+57 ; Work Phone
DO SET(.ARY,"WPN",36,2)
+58 ; Phone
DO SET(.ARY,"PH",36,3)
+59 IF ADD
SET PHM=$$ADDSEG^HLOAPI(.HLST,.ARY)
End DoDot:1
+60 QUIT
+61 ; Create RXR segment
RXR ;EP
+1 DO RXR^APSPES4
+2 QUIT
RXC ; Create RXC segment
+1 DO RXC^APSPES4
+2 QUIT
+3 ; Create DG1 segment
DG1 ;EP -
+1 DO DG1^APSPES4
+2 QUIT
+3 ; Create AL1 segment
AL1 ;EP -
+1 DO AL1^APSPES4
+2 QUIT
+3 ; Create MSA segment
MSA ;EP
+1 NEW MSA
+2 DO SET(.ARY,"MSA",0)
+3 DO SET(.ARY,"AA",1)
+4 DO SET(.ARY,"TODO-MSGID",2)
+5 DO SET(.ARY,"Transaction Successful",3)
+6 DO SET(.ARY,"todo-010",4)
+7 SET MSA=$$ADDSEG^HLOAPI(.HLST,.ARY)
+8 QUIT
+9 ; Create MSH segment
+10 ;EP
+11 NEW MSH
+12 DO SET(.ARY,"MSH",0)
+13 SET MSH=$$ADDSEG^HLOAPI(.HLST,.ARY)
+14 QUIT
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
+3 ; Return Related Institution for prescription
+4 ; Input: Pharmacy Division IEN
+5 ; Output: Institution Pointer (File 4)
GETRINST(PDIV) ;EP
+1 QUIT $$GET1^DIQ(59,PDIV,100,"I")
+2 ; Return NCPDP Route
GROUTE(RIEN) ;EP
+1 NEW RXROUTE
+2 SET RXROUTE=$$GET1^DIQ(51.2,RIEN,.01)
+3 QUIT RXROUTE
+4 ; Return NCPDP Dosage Form Code
+5 ; Input: FORM = IEN to Dosage Form File
+6 ; TYPE = 0(default) returns code; 1 returns IEN
GDFORM(FORM,TYPE) ;EP
+1 QUIT $$GET1^DIQ(50.606,FORM,9999999.01,$SELECT($GET(TYPE):"I",1:"E"))
+2 ; Return NCPDP Dosage Form Code Text
GDFMTXT(FORM) ;EP
+1 QUIT $$GET1^DIQ(9009033.7,$$GDFORM(FORM,1),1)
+2 ; Return NCPDP Quantity Qualifier mapped to Dispense Unit NCPDP Code field in File 50
+3 ; Input: DIEN- IEN to Drug File (50)
+4 ; Output: Returns .01 field value from APSP NCPDP Control Codes file
QTYQUAL(DIEN) ;EP
+1 NEW X,RET
+2 SET RET=""
+3 SET X=$$GET1^DIQ(50,DIEN,9999999.145,"I")
+4 IF +X
SET RET=$$GET1^DIQ(9009033.7,X,3)
+5 QUIT RET
QTYTXT(DIEN) ;EP
+1 NEW X,RET
+2 SET RET=""
+3 SET X=$$GET1^DIQ(50,DIEN,9999999.145,"I")
+4 IF +X
SET RET=$$GET1^DIQ(9009033.7,X,1)
+5 QUIT RET
+6 ; Return Pharmacy IEN
GPHM(RXIEN) ;EP
+1 QUIT $PIECE($GET(^PSRX(RXIEN,999999921)),U,4)
+2 ; Return Unit from Drug File
DRGUNITS(DIEN) ;EP
+1 QUIT $$GET1^DIQ(50,DIEN,902)
+2 ; Return NCPDP Units
SUNITS() ;EP
+1 QUIT ""
+2 ; Return adjusted Duration Value
ADJDUR(VAL) ;
+1 NEW N,D
+2 IF 'VAL
QUIT "INDEF"
+3 SET N=$EXTRACT(VAL,1,$LENGTH(VAL)-1)
+4 SET D=$EXTRACT(VAL,$LENGTH(VAL))
+5 QUIT D_N
+6 ; Find and return prepared segment array
PREPARY(SRC,SEG,RET,START) ;
+1 NEW IEN,LP
+2 SET IEN=$$FSEGIEN(.SRC,SEG,.START)
+3 IF 'IEN
QUIT
+4 SET LP=0
FOR
SET LP=$ORDER(SRC(IEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+5 MERGE RET(LP-1)=SRC(IEN,LP)
End DoDot:1
+6 QUIT
+7 ; Return IEN to particular segment in source array
+8 ; Optional START value can specify where in source to start search
FSEGIEN(SRC,SEG,START) ;
+1 NEW LP,RES
+2 SET (LP,RES)=0
+3 IF $GET(START)
SET LP=START
+4 FOR
SET LP=$ORDER(SRC(LP))
IF 'LP
QUIT
Begin DoDot:1
+5 IF $GET(SRC(LP,"SEGMENT TYPE"))=SEG
SET RES=LP
End DoDot:1
IF RES
QUIT
+6 QUIT RES
+7 ; Return SIG as a single string
GETSIG() ;EP
+1 NEW LP,RET
+2 SET RET=""
+3 SET LP=0
FOR
SET LP=$ORDER(^PSRX(RXIEN,"SIG1",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET RET=RET_^PSRX(RXIEN,"SIG1",LP,0)
End DoDot:1
+5 QUIT RET
+6 ; Return Provider Comments as a single string
GETPRC() ;EP -
+1 NEW LP,RET
+2 SET RET=""
+3 SET LP=0
FOR
SET LP=$ORDER(^PSRX(RXIEN,"PRC",LP))
IF 'LP
QUIT
Begin DoDot:1
+4 SET RET=RET_^PSRX(RXIEN,"PRC",LP,0)
End DoDot:1
+5 QUIT RET
+6 ; Return SPI number for user
SPI(USR) ; EP -
+1 QUIT $$GET1^DIQ(200,USR,43.99)
+2 ; Return HL7 substitution value
SUBST(RXIEN) ; EP -
+1 NEW VAL
+2 SET VAL=$$GET1^DIQ(52,RXIEN,9999999.25,"I")
+3 QUIT $SELECT(VAL=1!(VAL=7):"N",1:"G")
