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

APSPES1.m

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