APSPES4.m

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=""