APSPES4 ;IHS/MSC/PLS - SureScripts HL7 interface - con't;19-Oct-2015 14:30;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1016,1017,1018,1020**;Sep 23, 2004;Build 7
; Return array of message data
; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files
; Output: DATA
; HLMSTATE
;Handle the extra segment data from APSPES1
; Create RXR segment
RXR ;EP
N RX6
D SET(.ARY,"RXR",0)
S RX6=$O(^PSRX(RXIEN,6,0))
I RX6 D
.S RX6=^PSRX(RXIEN,6,RX6,0)
.D SET(.ARY,$S($P(RX6,U,7):$$GROUTE^APSPES1($P(RX6,U,7)),1:"OTH"),1)
S RX6=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
RXC ;Do the RXC segment
N DIEN
S DIEN=$P(RX0,U,6)
;This means its a compounding medication
I $P($G(^PSDRUG(DIEN,999999935)),U,1)=1 D CMP
Q
CMP ; Get compound data
N ING,NODE,CDRUG,CNDC,IND,AMT,UNIT,STR,SUNIT,RXNORM,RXCOM
S ING=0 F S ING=$O(^PSDRUG(DIEN,999999936,ING)) Q:'+ING D
.S NODE=$G(^PSDRUG(DIEN,999999936,ING,0))
.S CDRUG=$P(NODE,U,1)
.S CNDC=$$NDC(CDRUG)
.S IND=$P(NODE,U,4)
.S AMT=$P(NODE,U,2)
.S UNIT=$P($G(^PS(50.607,$P(NODE,U,3),0)),U,1)
.S IND=$S(IND=1:"B",1:"A")
.D SET(.ARY,"RXC",0)
.D SET(.ARY,IND,1,1) ;Additive/Base field
.D SET(.ARY,CNDC,2,1) ; NDC Value
.D SET(.ARY,$$GET1^DIQ(50,CDRUG,.01),2,2) ; Drug Name
.D SET(.ARY,"NDC",2,3) ; Coding System
.D SET(.ARY,AMT,3,1) ; Amt
.D SET(.ARY,UNIT,4,1) ; Units
.S SUNIT=$$GET1^DIQ(50,CDRUG,14.5,"E")
.S STR=$$GET1^DIQ(50,CDRUG,901,"E")
.D SET(.ARY,STR,5,1) ;Strength
.D SET(.ARY,SUNIT,6,1) ;Strength Units
.;I CNDC'="" D
.S RXNORM=$$RXNORDRG^APSPFNC1(DIEN)
.D SET(.ARY,RXNORM,7,1) ;RxNorm as alt id
.D SET(.ARY,"RXNORM",7,3) ;Code List
.S RXCOM=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
AL1 ;EP Send an AL1 segment
N AL1,RESULT,CNT,ALL,APSPAL,CT
D GETADR^APSPESAL(.RESULT,DFN,"A",.AL1)
I $D(RESULT)'>9 D Q
.I $D(AL1),AL1=0 S ALL="NKA"
.E S ALL="UNKNOWN"
.D SET(.ARY,"AL1",0)
.D SET(.ARY,"1",1)
.D SET(.ARY,"DA",2)
.D SET(.ARY,ALL,3)
.S AL1=$$ADDSEG^HLOAPI(.HLST,.ARY)
S CT=0,APSPAL=0
F S APSPAL=$O(RESULT(APSPAL)) Q:+APSPAL'>0 D
.S CT=CT+1
.D SET(.ARY,"AL1",0)
.D SET(.ARY,CT,1)
.D SET(.ARY,$P(RESULT(APSPAL),U,11),2)
.D SET(.ARY,$P(RESULT(APSPAL),U,3),3)
.D SET(.ARY,$P(RESULT(APSPAL),U,9),4)
.D SET(.ARY,$P(RESULT(APSPAL),U,10),5)
.D SET(.ARY,$P(RESULT(APSPAL),U,4),6)
.S AL1=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
; Create DG1 segment
DG1 ;EP
N CICODE,CITXT,DG1,ICDNAME,ICDTYPE,Z
S CICODE=$$GET1^DIQ(52,RXIEN,9999999.22) ; Clinical Indicator code
Q:'$L(CICODE)
S CICODE=$P(CICODE,";") ;P1020 - use first ICD
D SET(.ARY,"DG1",0)
D SET(.ARY,"1",1)
D SET(.ARY,CICODE,3)
I $$AICD D
.S Z=$$ICDDX^ICDEX(CICODE,DT)
.S ICDNAME=$P(Z,U,4)
.S ICDTYPE=$S($P(Z,U,20)=1:"I9",$P(Z,U,20)=30:"I10",1:"")
E D
.S ICDNAME=$P($$ICDDX^ICDCODE(CICODE,DT),U,4)
.S ICDTYPE="I9"
D SET(.ARY,ICDNAME,3,2) ; Clinical Indicator text
D SET(.ARY,ICDTYPE,3,3) ; Name of coding system
D SET(.ARY,"RX",6) ; Diagnosis type - Prescription (RX)
S DG1=$$ADDSEG^HLOAPI(.HLST,.ARY)
Q
;
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
FNDORD(MSGIEN) ;Find the orderable item for this request
N ORITM,RXNORM,NDC,NNDC,I,DRNM,POICT
S (NDC,RXNORM,ORITM)=""
S RXNORM=$$GETVAL^APSPES2(MSGIEN,"RXO",24,1)
I RXNORM="" S RXNORM=$$GETVAL^APSPES2(MSGIEN,"RXE",31,1)
I RXNORM'="" D
.S I="" F S I=$O(^C0CRXN(176.002,"B",RXNORM,I)) Q:I=""!(ORITM'="") D
..S NNDC=$P($G(^C0CRXN(176.002,I,0)),U,3)
..I NNDC'="" S ORITM=$$FNDDRG(NNDC)
I ORITM="" D
.S NDC=$$GETVAL^APSPES2(MSGIEN,"RXO",1,1)
.I NDC'="" S ORITM=$$FNDDRG(NDC)
;If all this still fails, try a name lookup
I ORITM="" D
.S DRNM=$$GETVAL^APSPES2(MSGIEN,"RXO",1,2)
.S ORITM=$$DRGNMOI($$UP^XLFSTR(DRNM))
Q ORITM
FNDDRG(NDC) ;Get the drug, and orderable items
N DRG,OI,ID
S OI=""
S DRG="" F S DRG=$O(^PSDRUG("ZNDC",NDC,DRG)) Q:DRG=""!(OI'="") D
.S OI=$$FNDOI(DRG)
I OI="" S OI=$$PRODNDC(NDC)
I OI="" D
.I $L(NDC=11) D
..S NDC="0"_NDC
..S OI=$$PRODNDC(NDC)
Q OI
;Try the lookup from the VA PRODUCT FILE
PRODNDC(NDC) ;product NDC
N VA,PROD,OI2
S OI2=""
S VA="" S VA=$O(^PSNDF(50.67,"NDC",NDC,VA))
I VA="" Q OI2
S PROD=$$GET1^DIQ(50.67,VA,5,"E")
S PROD=$E(PROD,1,30)
S DRG="" F S DRG=$O(^PSDRUG("VAPN",PROD,DRG)) Q:DRG=""!(OI'="") D
.S OI2=$$FNDOI(DRG)
Q OI2
FNDOI(DRG) ;find orderable item from drug
N POI,OI
S OI=""
S POI=$P($G(^PSDRUG(DRG,2)),U,1)
I POI'="" D
.Q:$$GET1^DIQ(50.7,POI,.04)
.S ID=POI_";99PSP"
.S OI="" S OI=$O(^ORD(101.43,"ID",ID,OI))
Q OI
NMPOI(DRNM) ;Match on name
N POICT,POI,POIARR,OI3,ID
S POICT=0,OI3=""
S POI="" F S POI=$O(^PS(50.7,"B",DRNM,POI)) Q:POI="" D
.S POICT=POICT+1
.S POIARR(POICT)=POI
;Only allowed one match so that we can't have different dose forms
I POICT=1 D
.S POI=$G(POIARR(POICT))
.Q:$$GET1^DIQ(50.7,POI,.04)
.S ID=POI_";99PSP"
.S OI3="" S OI3=$O(^ORD(101.43,"ID",ID,OI3))
Q OI3
; Match on Drug File entries
DRGNMOI(DNM) ;EP-
N IEN,LNM,NM,UDNM,OI,CDNM,POI
S UDNM=$$UP^XLFSTR(DNM)
S OI=0
S IEN=0 F S IEN=$O(^PSDRUG(IEN)) Q:'IEN!OI D
.Q:$G(^PSDRUG(IEN,"I")) ;inactive drug
.S LNM=$P($G(^PSDRUG(IEN,999999935)),U,2)
.S NM=$P($G(^PSDRUG(IEN,0)),U)
.S CDNM=$$UP^XLFSTR($S($L(LNM):LNM,1:NM))
.Q:CDNM'=UDNM ;names must match
.S POI=$P($G(^PSDRUG(IEN,2)),U)
.Q:'POI ;no linked pharmacy orderable item
.Q:$$GET1^DIQ(50.7,POI,.04) ;POI is inactive
.S OI=$O(^ORD(101.43,"ID",POI_";99PSP",OI))
Q OI
GETDSP(RET,IEN) ;Get the dispensed data from the Refill request IEN
N I,MSGID,HLMSG,DCODE,DRG,DCODEQ,DSIG,DSUP,DQTY,DREFILL,DDRUG,HLECH,DDRG,DEL,DDATE
N APSPPID,APSPDG1,APSPRXE,APSPRXO,APSPORC,APSPRXO,APSPRXE,APSPRXR,APSPRXD,APSPMSG,APSPDG1,NOTES
S HLECH="^~\&"
F I=1:1:4 D
.S HLECH(I)=$E(HLECH,I)
S MSGID=$$GET1^DIQ(9009033.91,IEN,.01,"E"),HLMSG=$$GHLDAT^APSPESG1(IEN)
S DEL="|"
D SHLVARS^APSPESG
S DCODE=$P($P(APSPRXD,DEL,3),HLECH(1),1)
S DRG=$P($P(APSPRXD,DEL,3),HLECH(1),2)
S DCODEQ=$P($P(APSPRXD,DEL,3),HLECH(1),3)
S DDRG=DRG_$S($L(DCODE):" ("_DCODEQ_":"_DCODE_")",1:"")
S DSIG=$P($P(APSPRXD,DEL,10),HLECH(1),1)
S DSUP=$P($P(APSPRXD,DEL,23),HLECH(1),1)
S DQTY=$P($P(APSPRXD,DEL,5),HLECH(1),1)
S DDATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P($P(APSPRXD,DEL,4),HLECH(1),1)),"5DZ0")
S DREFILL=$P($P(APSPRXD,DEL,9),HLECH(1),1)
S NOTES=$P($P(APSPRXD,DEL,16),HLECH(1),2)
;S RET=DRG_" "_DSIG_" Days Supply: "_DSUP_" QTY: "_DQTY_" Dt Written: "_DDATE
S RET=DRG_" "_DSIG
I NOTES'="" S RET=RET_" Notes: "_NOTES
Q
CHKNME(MSGIEN) ;Check names if there is no order
N HLNAME,HFNAME,HLDOB,HLSEX,MATCH,AGE,PT,SEX,NAME,FIRSTN,LOOK
;Match on birth dates and last names
S MATCH=0
D HLPID
S LOOK=HLNAME
F S LOOK=$O(^DPT("B",LOOK)) Q:LOOK=""!(MATCH>0) D
.Q:($P(LOOK,",")'=HLNAME)
.S PT=""
.F S PT=$O(^DPT("B",LOOK,PT)) Q:PT=""!(MATCH>0) D
..S NAME=$$GET1^DIQ(2,PT,.01)
..S FIRSTN=$P($P(NAME,",",2)," ",1)
..Q:FIRSTN'=HFNAME
..S AGE=$$GET1^DIQ(2,PT,.03,"I")
..S AGE=$$HLDATE^HLFNC(AGE,"DT")
..S SEX=$$GET1^DIQ(2,PT,.02,"I")
..I AGE=HLDOB&(SEX=HLSEX) S MATCH=PT
Q MATCH
CHKOPT(PAT) ;Find the match for the order patient
N HL7NAME,HLNAME,HFNAME,HLDOB,HLSEX,MATCH,AGE,LASTN,FIRSTN,NAME
S MATCH=0
D HLPID
S NAME=$$GET1^DIQ(2,PAT,.01)
S HL7NAME=$$HLNAME^HLFNC(NAME,"^")
S LASTN=$P(HL7NAME,U)
S FIRSTN=$P(HL7NAME,U,2)
I (LASTN=HLNAME)&(FIRSTN=HFNAME) S MATCH=PAT
Q MATCH
HLPID ;Find the hl7 name data
S HLNAME=$$UP^XLFSTR($$GETVAL^APSPES2(MSGIEN,"PID",5,1))
S HFNAME=$$UP^XLFSTR($$GETVAL^APSPES2(MSGIEN,"PID",5,2))
S HLDOB=$$GETVAL^APSPES2(MSGIEN,"PID",7)
I $L(HLDOB)>8 S HLDOB=$E(HLDOB,1,8)
S HLSEX=$$GETVAL^APSPES2(MSGIEN,"PID",8)
Q
CHKDRG(MSGIEN,RXIEN) ;Check the drug
N HLOI,RXOI,DRG
S HLOI=$$FNDORD(MSGIEN)
S DRG=$P($G(^PSRX(RXIEN,0)),U,6)
S RXOI=$$FNDOI(DRG)
Q $S(RXOI=HLOI:RXOI,1:0)
; APSPES4 SNDE900 RPC Support
SNDE900(RET,RRIEN) ;EP-
D ERR900($P(RRIEN,":",2),"Request has already been viewed.")
S RET=1
Q
; Send error message back
ERR900(RR,MSGTXT) ;EP-
N PARMS,ACK,ERR,HLMSGIEN,HLMSTATE,ACT,SEG
K ACK
S ACT=$$GET1^DIQ(9009033.91,RR,.08,"I")
S OCC=$S($G(OCC):OCC,ACT=3:"RP",ACT=4:"DF",1:"DF")
S HLMSGIEN=$$GET1^DIQ(9009033.91,RR,.05) ; Message ID
Q:'HLMSGIEN
S PARMS("ACK CODE")="AE"
S PARMS("MESSAGE TYPE")="RRE"
S PARMS("EVENT")="O12"
S PARMS("VERSION")=2.5
S PARMS("ACCEPT ACK TYPE")="AL"
S PARMS("ERROR MESSAGE")=MSGTXT
D PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
S HLFS=$G(DATA("HDR","FIELD SEPARATOR"))
S HLECH=HLMSTATE("HDR","ENCODING CHARACTERS")
Q:'$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR)
D SET^HLOAPI(.SEG,"ERR",0)
D SET^HLOAPI(.SEG,MSGTXT,8)
Q:'$$ADDSEG^HLOAPI(.ACK,.SEG)
I '$$SENDACK^HLOAPI2(.ACK,.ERR) D UPTRRACT^APSPES3(RR,$G(ERR,"There was a problem sending the HL7 message."))
Q
; Generate Renew Order
GENRENEW(MSGIEN,RXIEN,OPRV,REFILL,RRIEN) ;EP -
N ORIFN,VAL,DFN,LOC,RET,FLDS,ORLST,DEA,RXSTS,PAT,ORDERPT,HLITM
Q:'RXIEN "0^Prescription IEN not provided."
S VAL=""
S DFN=$P($G(^PSRX(RXIEN,0)),U,2)
Q:'DFN "0^Patient not found for supplied prescription IEN."
S ORIFN=+$P($G(^PSRX(RXIEN,"OR1")),U,2)
S RXSTS=$$GET1^DIQ(52,RXIEN,100,"I")
I ",12,14,15,"[(","_RXSTS_",") S VAL="Original order has been discontinued."
D:VAL="" VALID^ORWDXA(.VAL,ORIFN,"RN",OPRV)
;TODO - GENERATE DENIAL MESSAGE
Q:$L(VAL) 0_U_VAL ; Order can't be renewed. VAL contains refusal explanation
K VAL
S ORLST(1)=ORIFN
D RENEW^ORWDXC(.VAL,DFN,.ORLST)
S LOC=+$P($G(^OR(100,ORIFN,0)),U,10)
D RNWFLDS^ORWDXR(.RET,ORIFN)
S FLDS(1)=$G(RET(0))
S $P(FLDS(1),U,6)=$$GET1^DIQ(9009033.91,RRIEN,1.7,"I") ; Set Pharmacy
S FLDS("ORCHECK")=0
S:$G(RRIEN) FLDS("SSRREQIEN")=$G(RRIEN)
S FLDS("SSREFREQ")=1
D PREPPTXT^APSPES2($NA(FLDS("SSREFREQ")),$G(RRIEN))
S DEA=$$DEA^APSPES2($P($G(^PSRX(RXIEN,0)),U,6))
;S $P(FLDS(1),U,4)=$S($$DEACLS(DEA,"2345"):0,REFILL:1,1:0) ; Refill
S $P(FLDS(1),U,4)=$$GET1^DIQ(9009033.91,RRIEN,1.9)-1 ; Refills equal Fills -1
S FLDS(2)=$$GET1^DIQ(9009033.91,RRIEN,4.1) ; Notes to Pharmacist
K RET
D RENEW^ORWDXR(.RET,.ORIFN,DFN,OPRV,LOC,.FLDS)
;CHECK ORIFN FOR NEW ORDER
D:$G(ORIFN) EN^OCXOERR(DFN_U_+ORIFN_U_OPRV_"^^^^^1")
Q +$P($P($G(RET(1)),U),"~",2)
;
;Check to see if SSNUM already exists
CHKSSNUM(SSNUM) ;EP-
N ORGIEN
S ORGIEN=$O(^APSPRREQ("G",SSNUM,0))
Q:'ORGIEN 0
Q ORGIEN
; Add related item to parent
SETDUP(P,C) ;EP-
N FDA,ERR,IENS
S IENS="+1,"_P_","
S FDA(9009033.919,IENS,.01)=C
D UPDATE^DIE("","FDA")
Q
;Compare SIG of PON Request with HL7 SIG
COMPSIG(RET,ORIEN,RRIEN) ;EP
N MATCH,SIG,TXT,RXTXT,STR,DEL,HLMSG,MSGID,HLECH,I,RXIEN
S RET=0
S HLECH="^~\&"
S RRIEN=$G(RRIEN,0)
I 'RRIEN S RET=1 Q
S RXIEN=$$GET1^DIQ(9009033.91,RRIEN,.06,"I")
I 'RXIEN S RET=1 Q
F I=1:1:4 D
.S HLECH(I)=$E(HLECH,I)
S RXTXT="",RETXT=""
;S SIG=+$O(^OR(100,+ORIEN,4.5,"ID","SIG",0))
S TXT=0 F S TXT=$O(^PSRX(RXIEN,"SIG1",TXT)) Q:'+TXT D
.S STR=$G(^PSRX(RXIEN,"SIG1",TXT,0))
.S RXTXT=RXTXT_STR
S MSGID=$$GET1^DIQ(9009033.91,RRIEN,.01,"E"),HLMSG=$$GHLDAT^APSPESG1(RRIEN)
S DEL="|"
D SHLVARS^APSPESG
S RETXT=$P($P(APSPRXO,DEL,8),HLECH(1),2)
I RXTXT=RETXT S RET=1
Q
;;Add patient instructions and compare
;S PITXT=$$PITXT(ORIEN)
;I $L(PITXT) D
;.S ORTXT=ORTXT_" "_PITXT
;.I ORTXT=RETXT S RET=1
;Q
; Return PITXT
PITXT(ORIEN) ;EP-
N PI,TXT,STR,PITXT
S PITXT=""
S PI=+$O(^OR(100,+ORIEN,4.5,"ID","PI",0))
S TXT=0 F S TXT=$O(^OR(100,+ORIEN,4.5,PI,2,TXT)) Q:'+TXT D
.S STR=$G(^OR(100,+ORIEN,4.5,PI,2,TXT,0))
.S PITXT=PITXT_STR
Q PITXT
; Return NDC code for Drug File Entry
NDC(DRG) ; EP -
;1016 IHS/MSC/MGH Updated to get NDF from PSNDF file
N NDF,CODE
S CODE=""
S NDF=$P($G(^PSDRUG(DRG,"ND")),U,3)
I NDF'="" S CODE=$P($G(^PSNDF(50.68,NDF,1)),U,7)
I CODE="" S CODE=$TR($P($G(^PSDRUG(DRG,2)),U,4),"-","")
S:$L(CODE)=12 CODE=$E(CODE,2,12)
Q CODE
;
BADORP ; EP - Send bulletin regarding bad ORP acknowledgement message
S MSG(1)="HL7 Message "_$G(^HLB(MSGIEN,1))_$G(^HLB(MSGIEN,2))
S MSG(2)=" "
S MSG(3)="did not receive a valid NEWRX acknowledgement."
S MSG(4)=" "
S MSG(5)="Acknowledgement code: "_$G(AACK)
S MSG(6)="Error: "_$G(ERRTXT)
S MSG(7)=" "
S WHO("G.APSP EPRESCRIBING")=""
S:$G(OPRV) WHO(OPRV)=""
D BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
Q
; Send Notification to Ordering Provider
; Input: RXN = IEN to Prescription File
; MSG = Main message
; ALRTD = Alert data
; DFN = Patient IEN (optional)
; PVDIEN = Provider to received notification (optional)
; OIEN = Order File IEN
NOTIF(RXN,MSG,ALRTD,DFN,PVDIEN) ;EP
N PNAM,RET
N XQA,XQAID,XQADATA,XQAMSG
S:'$G(DFN) DFN=+$$GET1^DIQ(52,$G(RXN),2,"I")
Q:'DFN
S PNAM=$E($$GET1^DIQ(2,DFN,.01)_" ",1,9)
S XQAMSG=PNAM_" "_"("_$$HRC^APSPFUNC(DFN)_")"
S:'$G(PVDIEN) PVDIEN=$$GET1^DIQ(52,RXN,4,"I") ;TODO - change to Entering Person?
Q:'PVDIEN
S XQA(PVDIEN)=""
S XQAMSG=XQAMSG_$G(MSG)
S XQAID="OR"_","_DFN_","_99003
S XQADATA=$$GET1^DIQ(52,$G(RXN),39.3,"I")_"@"_$G(ALRTD)
D SETUP^XQALERT
Q
AICD() ;EP
Q $S($$VERSION^XPDUTL("AICD")="4.0":1,1:0)
APSPES4 ;IHS/MSC/PLS - SureScripts HL7 interface - con't;19-Oct-2015 14:30;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1016,1017,1018,1020**;Sep 23, 2004;Build 7
+2 ; Return array of message data
+3 ; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files
+4 ; Output: DATA
+5 ; HLMSTATE
+6 ;Handle the extra segment data from APSPES1
+7 ; Create RXR segment
RXR ;EP
+1 NEW RX6
+2 DO SET(.ARY,"RXR",0)
+3 SET RX6=$ORDER(^PSRX(RXIEN,6,0))
+4 IF RX6
Begin DoDot:1
+5 SET RX6=^PSRX(RXIEN,6,RX6,0)
+6 DO SET(.ARY,$SELECT($PIECE(RX6,U,7):$$GROUTE^APSPES1($PIECE(RX6,U,7)),1:"OTH"),1)
End DoDot:1
+7 SET RX6=$$ADDSEG^HLOAPI(.HLST,.ARY)
+8 QUIT
RXC ;Do the RXC segment
+1 NEW DIEN
+2 SET DIEN=$PIECE(RX0,U,6)
+3 ;This means its a compounding medication
+4 IF $PIECE($GET(^PSDRUG(DIEN,999999935)),U,1)=1
DO CMP
+5 QUIT
CMP ; Get compound data
+1 NEW ING,NODE,CDRUG,CNDC,IND,AMT,UNIT,STR,SUNIT,RXNORM,RXCOM
+2 SET ING=0
FOR
SET ING=$ORDER(^PSDRUG(DIEN,999999936,ING))
IF '+ING
QUIT
Begin DoDot:1
+3 SET NODE=$GET(^PSDRUG(DIEN,999999936,ING,0))
+4 SET CDRUG=$PIECE(NODE,U,1)
+5 SET CNDC=$$NDC(CDRUG)
+6 SET IND=$PIECE(NODE,U,4)
+7 SET AMT=$PIECE(NODE,U,2)
+8 SET UNIT=$PIECE($GET(^PS(50.607,$PIECE(NODE,U,3),0)),U,1)
+9 SET IND=$SELECT(IND=1:"B",1:"A")
+10 DO SET(.ARY,"RXC",0)
+11 ;Additive/Base field
DO SET(.ARY,IND,1,1)
+12 ; NDC Value
DO SET(.ARY,CNDC,2,1)
+13 ; Drug Name
DO SET(.ARY,$$GET1^DIQ(50,CDRUG,.01),2,2)
+14 ; Coding System
DO SET(.ARY,"NDC",2,3)
+15 ; Amt
DO SET(.ARY,AMT,3,1)
+16 ; Units
DO SET(.ARY,UNIT,4,1)
+17 SET SUNIT=$$GET1^DIQ(50,CDRUG,14.5,"E")
+18 SET STR=$$GET1^DIQ(50,CDRUG,901,"E")
+19 ;Strength
DO SET(.ARY,STR,5,1)
+20 ;Strength Units
DO SET(.ARY,SUNIT,6,1)
+21 ;I CNDC'="" D
+22 SET RXNORM=$$RXNORDRG^APSPFNC1(DIEN)
+23 ;RxNorm as alt id
DO SET(.ARY,RXNORM,7,1)
+24 ;Code List
DO SET(.ARY,"RXNORM",7,3)
+25 SET RXCOM=$$ADDSEG^HLOAPI(.HLST,.ARY)
End DoDot:1
+26 QUIT
AL1 ;EP Send an AL1 segment
+1 NEW AL1,RESULT,CNT,ALL,APSPAL,CT
+2 DO GETADR^APSPESAL(.RESULT,DFN,"A",.AL1)
+3 IF $DATA(RESULT)'>9
Begin DoDot:1
+4 IF $DATA(AL1)
IF AL1=0
SET ALL="NKA"
+5 IF '$TEST
SET ALL="UNKNOWN"
+6 DO SET(.ARY,"AL1",0)
+7 DO SET(.ARY,"1",1)
+8 DO SET(.ARY,"DA",2)
+9 DO SET(.ARY,ALL,3)
+10 SET AL1=$$ADDSEG^HLOAPI(.HLST,.ARY)
End DoDot:1
QUIT
+11 SET CT=0
SET APSPAL=0
+12 FOR
SET APSPAL=$ORDER(RESULT(APSPAL))
IF +APSPAL'>0
QUIT
Begin DoDot:1
+13 SET CT=CT+1
+14 DO SET(.ARY,"AL1",0)
+15 DO SET(.ARY,CT,1)
+16 DO SET(.ARY,$PIECE(RESULT(APSPAL),U,11),2)
+17 DO SET(.ARY,$PIECE(RESULT(APSPAL),U,3),3)
+18 DO SET(.ARY,$PIECE(RESULT(APSPAL),U,9),4)
+19 DO SET(.ARY,$PIECE(RESULT(APSPAL),U,10),5)
+20 DO SET(.ARY,$PIECE(RESULT(APSPAL),U,4),6)
+21 SET AL1=$$ADDSEG^HLOAPI(.HLST,.ARY)
End DoDot:1
+22 QUIT
+23 ; Create DG1 segment
DG1 ;EP
+1 NEW CICODE,CITXT,DG1,ICDNAME,ICDTYPE,Z
+2 ; Clinical Indicator code
SET CICODE=$$GET1^DIQ(52,RXIEN,9999999.22)
+3 IF '$LENGTH(CICODE)
QUIT
+4 ;P1020 - use first ICD
SET CICODE=$PIECE(CICODE,";")
+5 DO SET(.ARY,"DG1",0)
+6 DO SET(.ARY,"1",1)
+7 DO SET(.ARY,CICODE,3)
+8 IF $$AICD
Begin DoDot:1
+9 SET Z=$$ICDDX^ICDEX(CICODE,DT)
+10 SET ICDNAME=$PIECE(Z,U,4)
+11 SET ICDTYPE=$SELECT($PIECE(Z,U,20)=1:"I9",$PIECE(Z,U,20)=30:"I10",1:"")
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET ICDNAME=$PIECE($$ICDDX^ICDCODE(CICODE,DT),U,4)
+14 SET ICDTYPE="I9"
End DoDot:1
+15 ; Clinical Indicator text
DO SET(.ARY,ICDNAME,3,2)
+16 ; Name of coding system
DO SET(.ARY,ICDTYPE,3,3)
+17 ; Diagnosis type - Prescription (RX)
DO SET(.ARY,"RX",6)
+18 SET DG1=$$ADDSEG^HLOAPI(.HLST,.ARY)
+19 QUIT
+20 ;
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
FNDORD(MSGIEN) ;Find the orderable item for this request
+1 NEW ORITM,RXNORM,NDC,NNDC,I,DRNM,POICT
+2 SET (NDC,RXNORM,ORITM)=""
+3 SET RXNORM=$$GETVAL^APSPES2(MSGIEN,"RXO",24,1)
+4 IF RXNORM=""
SET RXNORM=$$GETVAL^APSPES2(MSGIEN,"RXE",31,1)
+5 IF RXNORM'=""
Begin DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(^C0CRXN(176.002,"B",RXNORM,I))
IF I=""!(ORITM'="")
QUIT
Begin DoDot:2
+7 SET NNDC=$PIECE($GET(^C0CRXN(176.002,I,0)),U,3)
+8 IF NNDC'=""
SET ORITM=$$FNDDRG(NNDC)
End DoDot:2
End DoDot:1
+9 IF ORITM=""
Begin DoDot:1
+10 SET NDC=$$GETVAL^APSPES2(MSGIEN,"RXO",1,1)
+11 IF NDC'=""
SET ORITM=$$FNDDRG(NDC)
End DoDot:1
+12 ;If all this still fails, try a name lookup
+13 IF ORITM=""
Begin DoDot:1
+14 SET DRNM=$$GETVAL^APSPES2(MSGIEN,"RXO",1,2)
+15 SET ORITM=$$DRGNMOI($$UP^XLFSTR(DRNM))
End DoDot:1
+16 QUIT ORITM
FNDDRG(NDC) ;Get the drug, and orderable items
+1 NEW DRG,OI,ID
+2 SET OI=""
+3 SET DRG=""
FOR
SET DRG=$ORDER(^PSDRUG("ZNDC",NDC,DRG))
IF DRG=""!(OI'="")
QUIT
Begin DoDot:1
+4 SET OI=$$FNDOI(DRG)
End DoDot:1
+5 IF OI=""
SET OI=$$PRODNDC(NDC)
+6 IF OI=""
Begin DoDot:1
+7 IF $LENGTH(NDC=11)
Begin DoDot:2
+8 SET NDC="0"_NDC
+9 SET OI=$$PRODNDC(NDC)
End DoDot:2
End DoDot:1
+10 QUIT OI
+11 ;Try the lookup from the VA PRODUCT FILE
PRODNDC(NDC) ;product NDC
+1 NEW VA,PROD,OI2
+2 SET OI2=""
+3 SET VA=""
SET VA=$ORDER(^PSNDF(50.67,"NDC",NDC,VA))
+4 IF VA=""
QUIT OI2
+5 SET PROD=$$GET1^DIQ(50.67,VA,5,"E")
+6 SET PROD=$EXTRACT(PROD,1,30)
+7 SET DRG=""
FOR
SET DRG=$ORDER(^PSDRUG("VAPN",PROD,DRG))
IF DRG=""!(OI'="")
QUIT
Begin DoDot:1
+8 SET OI2=$$FNDOI(DRG)
End DoDot:1
+9 QUIT OI2
FNDOI(DRG) ;find orderable item from drug
+1 NEW POI,OI
+2 SET OI=""
+3 SET POI=$PIECE($GET(^PSDRUG(DRG,2)),U,1)
+4 IF POI'=""
Begin DoDot:1
+5 IF $$GET1^DIQ(50.7,POI,.04)
QUIT
+6 SET ID=POI_";99PSP"
+7 SET OI=""
SET OI=$ORDER(^ORD(101.43,"ID",ID,OI))
End DoDot:1
+8 QUIT OI
NMPOI(DRNM) ;Match on name
+1 NEW POICT,POI,POIARR,OI3,ID
+2 SET POICT=0
SET OI3=""
+3 SET POI=""
FOR
SET POI=$ORDER(^PS(50.7,"B",DRNM,POI))
IF POI=""
QUIT
Begin DoDot:1
+4 SET POICT=POICT+1
+5 SET POIARR(POICT)=POI
End DoDot:1
+6 ;Only allowed one match so that we can't have different dose forms
+7 IF POICT=1
Begin DoDot:1
+8 SET POI=$GET(POIARR(POICT))
+9 IF $$GET1^DIQ(50.7,POI,.04)
QUIT
+10 SET ID=POI_";99PSP"
+11 SET OI3=""
SET OI3=$ORDER(^ORD(101.43,"ID",ID,OI3))
End DoDot:1
+12 QUIT OI3
+13 ; Match on Drug File entries
DRGNMOI(DNM) ;EP-
+1 NEW IEN,LNM,NM,UDNM,OI,CDNM,POI
+2 SET UDNM=$$UP^XLFSTR(DNM)
+3 SET OI=0
+4 SET IEN=0
FOR
SET IEN=$ORDER(^PSDRUG(IEN))
IF 'IEN!OI
QUIT
Begin DoDot:1
+5 ;inactive drug
IF $GET(^PSDRUG(IEN,"I"))
QUIT
+6 SET LNM=$PIECE($GET(^PSDRUG(IEN,999999935)),U,2)
+7 SET NM=$PIECE($GET(^PSDRUG(IEN,0)),U)
+8 SET CDNM=$$UP^XLFSTR($SELECT($LENGTH(LNM):LNM,1:NM))
+9 ;names must match
IF CDNM'=UDNM
QUIT
+10 SET POI=$PIECE($GET(^PSDRUG(IEN,2)),U)
+11 ;no linked pharmacy orderable item
IF 'POI
QUIT
+12 ;POI is inactive
IF $$GET1^DIQ(50.7,POI,.04)
QUIT
+13 SET OI=$ORDER(^ORD(101.43,"ID",POI_";99PSP",OI))
End DoDot:1
+14 QUIT OI
GETDSP(RET,IEN) ;Get the dispensed data from the Refill request IEN
+1 NEW I,MSGID,HLMSG,DCODE,DRG,DCODEQ,DSIG,DSUP,DQTY,DREFILL,DDRUG,HLECH,DDRG,DEL,DDATE
+2 NEW APSPPID,APSPDG1,APSPRXE,APSPRXO,APSPORC,APSPRXO,APSPRXE,APSPRXR,APSPRXD,APSPMSG,APSPDG1,NOTES
+3 SET HLECH="^~\&"
+4 FOR I=1:1:4
Begin DoDot:1
+5 SET HLECH(I)=$EXTRACT(HLECH,I)
End DoDot:1
+6 SET MSGID=$$GET1^DIQ(9009033.91,IEN,.01,"E")
SET HLMSG=$$GHLDAT^APSPESG1(IEN)
+7 SET DEL="|"
+8 DO SHLVARS^APSPESG
+9 SET DCODE=$PIECE($PIECE(APSPRXD,DEL,3),HLECH(1),1)
+10 SET DRG=$PIECE($PIECE(APSPRXD,DEL,3),HLECH(1),2)
+11 SET DCODEQ=$PIECE($PIECE(APSPRXD,DEL,3),HLECH(1),3)
+12 SET DDRG=DRG_$SELECT($LENGTH(DCODE):" ("_DCODEQ_":"_DCODE_")",1:"")
+13 SET DSIG=$PIECE($PIECE(APSPRXD,DEL,10),HLECH(1),1)
+14 SET DSUP=$PIECE($PIECE(APSPRXD,DEL,23),HLECH(1),1)
+15 SET DQTY=$PIECE($PIECE(APSPRXD,DEL,5),HLECH(1),1)
+16 SET DDATE=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE($PIECE(APSPRXD,DEL,4),HLECH(1),1)),"5DZ0")
+17 SET DREFILL=$PIECE($PIECE(APSPRXD,DEL,9),HLECH(1),1)
+18 SET NOTES=$PIECE($PIECE(APSPRXD,DEL,16),HLECH(1),2)
+19 ;S RET=DRG_" "_DSIG_" Days Supply: "_DSUP_" QTY: "_DQTY_" Dt Written: "_DDATE
+20 SET RET=DRG_" "_DSIG
+21 IF NOTES'=""
SET RET=RET_" Notes: "_NOTES
+22 QUIT
CHKNME(MSGIEN) ;Check names if there is no order
+1 NEW HLNAME,HFNAME,HLDOB,HLSEX,MATCH,AGE,PT,SEX,NAME,FIRSTN,LOOK
+2 ;Match on birth dates and last names
+3 SET MATCH=0
+4 DO HLPID
+5 SET LOOK=HLNAME
+6 FOR
SET LOOK=$ORDER(^DPT("B",LOOK))
IF LOOK=""!(MATCH>0)
QUIT
Begin DoDot:1
+7 IF ($PIECE(LOOK,",")'=HLNAME)
QUIT
+8 SET PT=""
+9 FOR
SET PT=$ORDER(^DPT("B",LOOK,PT))
IF PT=""!(MATCH>0)
QUIT
Begin DoDot:2
+10 SET NAME=$$GET1^DIQ(2,PT,.01)
+11 SET FIRSTN=$PIECE($PIECE(NAME,",",2)," ",1)
+12 IF FIRSTN'=HFNAME
QUIT
+13 SET AGE=$$GET1^DIQ(2,PT,.03,"I")
+14 SET AGE=$$HLDATE^HLFNC(AGE,"DT")
+15 SET SEX=$$GET1^DIQ(2,PT,.02,"I")
+16 IF AGE=HLDOB&(SEX=HLSEX)
SET MATCH=PT
End DoDot:2
End DoDot:1
+17 QUIT MATCH
CHKOPT(PAT) ;Find the match for the order patient
+1 NEW HL7NAME,HLNAME,HFNAME,HLDOB,HLSEX,MATCH,AGE,LASTN,FIRSTN,NAME
+2 SET MATCH=0
+3 DO HLPID
+4 SET NAME=$$GET1^DIQ(2,PAT,.01)
+5 SET HL7NAME=$$HLNAME^HLFNC(NAME,"^")
+6 SET LASTN=$PIECE(HL7NAME,U)
+7 SET FIRSTN=$PIECE(HL7NAME,U,2)
+8 IF (LASTN=HLNAME)&(FIRSTN=HFNAME)
SET MATCH=PAT
+9 QUIT MATCH
HLPID ;Find the hl7 name data
+1 SET HLNAME=$$UP^XLFSTR($$GETVAL^APSPES2(MSGIEN,"PID",5,1))
+2 SET HFNAME=$$UP^XLFSTR($$GETVAL^APSPES2(MSGIEN,"PID",5,2))
+3 SET HLDOB=$$GETVAL^APSPES2(MSGIEN,"PID",7)
+4 IF $LENGTH(HLDOB)>8
SET HLDOB=$EXTRACT(HLDOB,1,8)
+5 SET HLSEX=$$GETVAL^APSPES2(MSGIEN,"PID",8)
+6 QUIT
CHKDRG(MSGIEN,RXIEN) ;Check the drug
+1 NEW HLOI,RXOI,DRG
+2 SET HLOI=$$FNDORD(MSGIEN)
+3 SET DRG=$PIECE($GET(^PSRX(RXIEN,0)),U,6)
+4 SET RXOI=$$FNDOI(DRG)
+5 QUIT $SELECT(RXOI=HLOI:RXOI,1:0)
+6 ; APSPES4 SNDE900 RPC Support
SNDE900(RET,RRIEN) ;EP-
+1 DO ERR900($PIECE(RRIEN,":",2),"Request has already been viewed.")
+2 SET RET=1
+3 QUIT
+4 ; Send error message back
ERR900(RR,MSGTXT) ;EP-
+1 NEW PARMS,ACK,ERR,HLMSGIEN,HLMSTATE,ACT,SEG
+2 KILL ACK
+3 SET ACT=$$GET1^DIQ(9009033.91,RR,.08,"I")
+4 SET OCC=$SELECT($GET(OCC):OCC,ACT=3:"RP",ACT=4:"DF",1:"DF")
+5 ; Message ID
SET HLMSGIEN=$$GET1^DIQ(9009033.91,RR,.05)
+6 IF 'HLMSGIEN
QUIT
+7 SET PARMS("ACK CODE")="AE"
+8 SET PARMS("MESSAGE TYPE")="RRE"
+9 SET PARMS("EVENT")="O12"
+10 SET PARMS("VERSION")=2.5
+11 SET PARMS("ACCEPT ACK TYPE")="AL"
+12 SET PARMS("ERROR MESSAGE")=MSGTXT
+13 DO PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
+14 SET HLFS=$GET(DATA("HDR","FIELD SEPARATOR"))
+15 SET HLECH=HLMSTATE("HDR","ENCODING CHARACTERS")
+16 IF '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR)
QUIT
+17 DO SET^HLOAPI(.SEG,"ERR",0)
+18 DO SET^HLOAPI(.SEG,MSGTXT,8)
+19 IF '$$ADDSEG^HLOAPI(.ACK,.SEG)
QUIT
+20 IF '$$SENDACK^HLOAPI2(.ACK,.ERR)
DO UPTRRACT^APSPES3(RR,$GET(ERR,"There was a problem sending the HL7 message."))
+21 QUIT
+22 ; Generate Renew Order
GENRENEW(MSGIEN,RXIEN,OPRV,REFILL,RRIEN) ;EP -
+1 NEW ORIFN,VAL,DFN,LOC,RET,FLDS,ORLST,DEA,RXSTS,PAT,ORDERPT,HLITM
+2 IF 'RXIEN
QUIT "0^Prescription IEN not provided."
+3 SET VAL=""
+4 SET DFN=$PIECE($GET(^PSRX(RXIEN,0)),U,2)
+5 IF 'DFN
QUIT "0^Patient not found for supplied prescription IEN."
+6 SET ORIFN=+$PIECE($GET(^PSRX(RXIEN,"OR1")),U,2)
+7 SET RXSTS=$$GET1^DIQ(52,RXIEN,100,"I")
+8 IF ",12,14,15,"[(","_RXSTS_",")
SET VAL="Original order has been discontinued."
+9 IF VAL=""
DO VALID^ORWDXA(.VAL,ORIFN,"RN",OPRV)
+10 ;TODO - GENERATE DENIAL MESSAGE
+11 ; Order can't be renewed. VAL contains refusal explanation
IF $LENGTH(VAL)
QUIT 0_U_VAL
+12 KILL VAL
+13 SET ORLST(1)=ORIFN
+14 DO RENEW^ORWDXC(.VAL,DFN,.ORLST)
+15 SET LOC=+$PIECE($GET(^OR(100,ORIFN,0)),U,10)
+16 DO RNWFLDS^ORWDXR(.RET,ORIFN)
+17 SET FLDS(1)=$GET(RET(0))
+18 ; Set Pharmacy
SET $PIECE(FLDS(1),U,6)=$$GET1^DIQ(9009033.91,RRIEN,1.7,"I")
+19 SET FLDS("ORCHECK")=0
+20 IF $GET(RRIEN)
SET FLDS("SSRREQIEN")=$GET(RRIEN)
+21 SET FLDS("SSREFREQ")=1
+22 DO PREPPTXT^APSPES2($NAME(FLDS("SSREFREQ")),$GET(RRIEN))
+23 SET DEA=$$DEA^APSPES2($PIECE($GET(^PSRX(RXIEN,0)),U,6))
+24 ;S $P(FLDS(1),U,4)=$S($$DEACLS(DEA,"2345"):0,REFILL:1,1:0) ; Refill
+25 ; Refills equal Fills -1
SET $PIECE(FLDS(1),U,4)=$$GET1^DIQ(9009033.91,RRIEN,1.9)-1
+26 ; Notes to Pharmacist
SET FLDS(2)=$$GET1^DIQ(9009033.91,RRIEN,4.1)
+27 KILL RET
+28 DO RENEW^ORWDXR(.RET,.ORIFN,DFN,OPRV,LOC,.FLDS)
+29 ;CHECK ORIFN FOR NEW ORDER
+30 IF $GET(ORIFN)
DO EN^OCXOERR(DFN_U_+ORIFN_U_OPRV_"^^^^^1")
+31 QUIT +$PIECE($PIECE($GET(RET(1)),U),"~",2)
+32 ;
+33 ;Check to see if SSNUM already exists
CHKSSNUM(SSNUM) ;EP-
+1 NEW ORGIEN
+2 SET ORGIEN=$ORDER(^APSPRREQ("G",SSNUM,0))
+3 IF 'ORGIEN
QUIT 0
+4 QUIT ORGIEN
+5 ; Add related item to parent
SETDUP(P,C) ;EP-
+1 NEW FDA,ERR,IENS
+2 SET IENS="+1,"_P_","
+3 SET FDA(9009033.919,IENS,.01)=C
+4 DO UPDATE^DIE("","FDA")
+5 QUIT
+6 ;Compare SIG of PON Request with HL7 SIG
COMPSIG(RET,ORIEN,RRIEN) ;EP
+1 NEW MATCH,SIG,TXT,RXTXT,STR,DEL,HLMSG,MSGID,HLECH,I,RXIEN
+2 SET RET=0
+3 SET HLECH="^~\&"
+4 SET RRIEN=$GET(RRIEN,0)
+5 IF 'RRIEN
SET RET=1
QUIT
+6 SET RXIEN=$$GET1^DIQ(9009033.91,RRIEN,.06,"I")
+7 IF 'RXIEN
SET RET=1
QUIT
+8 FOR I=1:1:4
Begin DoDot:1
+9 SET HLECH(I)=$EXTRACT(HLECH,I)
End DoDot:1
+10 SET RXTXT=""
SET RETXT=""
+11 ;S SIG=+$O(^OR(100,+ORIEN,4.5,"ID","SIG",0))
+12 SET TXT=0
FOR
SET TXT=$ORDER(^PSRX(RXIEN,"SIG1",TXT))
IF '+TXT
QUIT
Begin DoDot:1
+13 SET STR=$GET(^PSRX(RXIEN,"SIG1",TXT,0))
+14 SET RXTXT=RXTXT_STR
End DoDot:1
+15 SET MSGID=$$GET1^DIQ(9009033.91,RRIEN,.01,"E")
SET HLMSG=$$GHLDAT^APSPESG1(RRIEN)
+16 SET DEL="|"
+17 DO SHLVARS^APSPESG
+18 SET RETXT=$PIECE($PIECE(APSPRXO,DEL,8),HLECH(1),2)
+19 IF RXTXT=RETXT
SET RET=1
+20 QUIT
+21 ;;Add patient instructions and compare
+22 ;S PITXT=$$PITXT(ORIEN)
+23 ;I $L(PITXT) D
+24 ;.S ORTXT=ORTXT_" "_PITXT
+25 ;.I ORTXT=RETXT S RET=1
+26 ;Q
+27 ; Return PITXT
PITXT(ORIEN) ;EP-
+1 NEW PI,TXT,STR,PITXT
+2 SET PITXT=""
+3 SET PI=+$ORDER(^OR(100,+ORIEN,4.5,"ID","PI",0))
+4 SET TXT=0
FOR
SET TXT=$ORDER(^OR(100,+ORIEN,4.5,PI,2,TXT))
IF '+TXT
QUIT
Begin DoDot:1
+5 SET STR=$GET(^OR(100,+ORIEN,4.5,PI,2,TXT,0))
+6 SET PITXT=PITXT_STR
End DoDot:1
+7 QUIT PITXT
+8 ; Return NDC code for Drug File Entry
NDC(DRG) ; EP -
+1 ;1016 IHS/MSC/MGH Updated to get NDF from PSNDF file
+2 NEW NDF,CODE
+3 SET CODE=""
+4 SET NDF=$PIECE($GET(^PSDRUG(DRG,"ND")),U,3)
+5 IF NDF'=""
SET CODE=$PIECE($GET(^PSNDF(50.68,NDF,1)),U,7)
+6 IF CODE=""
SET CODE=$TRANSLATE($PIECE($GET(^PSDRUG(DRG,2)),U,4),"-","")
+7 IF $LENGTH(CODE)=12
SET CODE=$EXTRACT(CODE,2,12)
+8 QUIT CODE
+9 ;
BADORP ; EP - Send bulletin regarding bad ORP acknowledgement message
+1 SET MSG(1)="HL7 Message "_$GET(^HLB(MSGIEN,1))_$GET(^HLB(MSGIEN,2))
+2 SET MSG(2)=" "
+3 SET MSG(3)="did not receive a valid NEWRX acknowledgement."
+4 SET MSG(4)=" "
+5 SET MSG(5)="Acknowledgement code: "_$GET(AACK)
+6 SET MSG(6)="Error: "_$GET(ERRTXT)
+7 SET MSG(7)=" "
+8 SET WHO("G.APSP EPRESCRIBING")=""
+9 IF $GET(OPRV)
SET WHO(OPRV)=""
+10 DO BULL^APSPES2("HL7 ERROR","APSP eRx Interface",.WHO,.MSG)
+11 QUIT
+12 ; Send Notification to Ordering Provider
+13 ; Input: RXN = IEN to Prescription File
+14 ; MSG = Main message
+15 ; ALRTD = Alert data
+16 ; DFN = Patient IEN (optional)
+17 ; PVDIEN = Provider to received notification (optional)
+18 ; OIEN = Order File IEN
NOTIF(RXN,MSG,ALRTD,DFN,PVDIEN) ;EP
+1 NEW PNAM,RET
+2 NEW XQA,XQAID,XQADATA,XQAMSG
+3 IF '$GET(DFN)
SET DFN=+$$GET1^DIQ(52,$GET(RXN),2,"I")
+4 IF 'DFN
QUIT
+5 SET PNAM=$EXTRACT($$GET1^DIQ(2,DFN,.01)_" ",1,9)
+6 SET XQAMSG=PNAM_" "_"("_$$HRC^APSPFUNC(DFN)_")"
+7 ;TODO - change to Entering Person?
IF '$GET(PVDIEN)
SET PVDIEN=$$GET1^DIQ(52,RXN,4,"I")
+8 IF 'PVDIEN
QUIT
+9 SET XQA(PVDIEN)=""
+10 SET XQAMSG=XQAMSG_$GET(MSG)
+11 SET XQAID="OR"_","_DFN_","_99003
+12 SET XQADATA=$$GET1^DIQ(52,$GET(RXN),39.3,"I")_"@"_$GET(ALRTD)
+13 DO SETUP^XQALERT
+14 QUIT
AICD() ;EP
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")="4.0":1,1:0)
