APSPES2 ;IHS/MSC/PLS - SureScripts HL7 interface - con't;23-Mar-2015 09:06;DU
;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1011,1016,1018**;Sep 23, 2004;Build 21
; Return array of message data
; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files
; Output: DATA
; HLMSTATE
PARSE(DATA,MIEN,HLMSTATE) ;EP
N SEG,CNT
Q:'$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)
M DATA("HDR")=HLMSTATE("HDR")
S CNT=0
F Q:'$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG) D
.S CNT=CNT+1
.M DATA(CNT)=SEG
Q
; Process incoming RDS message
DISP ;EP
N DATA,ARY,SEGORC,SEGIEN,SEGRXD,ERR,RET
N DRG,DCODE,DCODEQ,PVDIEN,DSPNUM,RXIEN
Q:'$G(HLMSGIEN)
D PARSE(.DATA,HLMSGIEN,.HLMSTATE)
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ORC")
Q:'SEGIEN 0
M SEGORC=DATA(SEGIEN)
Q:$$GET^HLOPRS(.SEGORC,1,1)'="OK"
S PVDIEN=$$GET^HLOPRS(.SEGORC,10,1)
S RXIEN=$$GET^HLOPRS(.SEGORC,2,1)
Q:'RXIEN
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"RXD")
Q:'SEGIEN
M SEGRXD=DATA(SEGIEN)
S DSPNUM=$$GET^HLOPRS(.SEGRXD,1)
Q:'DSPNUM
S DSPNUM=DSPNUM-1 ;Adjust fill offset - original = 0
S DCODE=$$GET^HLOPRS(.SEGRXD,2,1)
S DRG=$$GET^HLOPRS(.SEGRXD,2,2)
S DCODEQ=$$GET^HLOPRS(.SEGRXD,2,3)
S ARY("REASON")="X"
S ARY("TYPE")="U"
S ARY("RX REF")=$S(DSPNUM>5:DSPNUM+1,1:DSPNUM) ; adjust for 6=partial
S ARY("COM")="DDrg:"_DRG_$S($L(DCODE):" ("_DCODEQ_":"_DCODE_")",1:"")
S ARY("USER")=PVDIEN
D UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
I DATA("HDR","APP ACK TYPE")="AL" D
.; Generate APP Ack
.N PARMS,ACK,ERR
.S PARMS("ACK CODE")="AA"
.I '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR) W !,ERR Q
.I '$$SENDACK^HLOAPI2(.ACK,.ERR) W !,ERR Q
Q
DSP ;
N HLMSGIEN,HLMSTATE,PARMS
S HLMSGIEN=200000000001
D PARSE(.DATA,HLMSGIEN,.HLMSTATE)
S PARMS("ACK CODE")="AA"
I '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR) W !,ERR Q
I '$$SENDACK^HLOAPI2(.ACK,.ERR) W !,ERR Q
Q
; Send bulletin
BULL(XMSUB,XMDUZ,WHO,MSG) ;EP
N XMY,XMTEXT
M XMY=WHO
S XMTEXT="MSG("
D ^XMD
Q
; Return Ordering Provider for HL7 Message
OPRV(MSGIEN) ; EP
N RXIEN,VAL
S VAL=0
S RXIEN=+$$RXIEN(MSGIEN)
Q:'RXIEN ""
Q +$P($G(^PSRX(RXIEN,0)),U,16)
; Return RX IEN
; Input: MSGIEN - HLO Message IEN
; TGL - default to 0, 1=return numeric value in HL7 message
RXIEN(MSGIEN,TGL) ; EP
N RET,RXN
S TGL=$G(TGL,0)
D PARSE(.DATA,MSGIEN,.HLMSTATE)
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ORC")
Q:'SEGIEN ""
M SEGORC=DATA(SEGIEN)
S RXN=$$GET^HLOPRS(.SEGORC,2,1)
S RET=$S(TGL:RXN,$D(^PSRX(+RXN,0)):+RXN,1:0)
Q RET
; Return Pharmacy Info for Activity Log
; Input - RXIEN - Prescription IEN
PHMINFO(RXIEN) ; EP -
N PHM
S PHM=$$GPHM^APSPES1(RXIEN)
Q:'PHM "UNKNOWN"
Q $$GET1^DIQ(9009033.9,PHM,.01)_" "_$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1))
;
REFRES ; EP - Refill request callback
;Build response to Refill Request
N DATA,PARMS,SEG,ACK,ARY,ERR,ORID,SEGRX0,REFILL,RR,ORITM,PRV,DFN
N RXIEN,FN,DEA,MATCHK
S MATCHK=""
D PARSE^APSPES2(.DATA,$G(HLMSGIEN),.HLMSTATE)
; Create entry in APSP REFILL REQUEST file
; If possible, generate order
S FN=9009033.91
S RR=$$ADDRR(+$G(HLMSGIEN))
Q:$$GET1^DIQ(9009033.91,RR,.03,"I")=8 ;Do not process duplicate record
S RXIEN=+$$GET1^DIQ(9009033.91,RR,.06,"I")
S DEA=$$DEA($P($G(^PSRX(RXIEN,0)),U,6))
I RR,RXIEN D ;,'$$DEACLS(DEA,2) D
.I '$D(^PSRX(RXIEN,0)) D Q
..S MATCHK=MATCHK_"Z"
.;Only allow automap if patient and provider match and there is an order
.I MATCHK["P"&(MATCHK["D") D
..S ORID=$$GENRENEW^APSPES4(HLMSGIEN,RXIEN,$$GET1^DIQ(52,RXIEN,16,"I"),$$GETVAL(HLMSGIEN,"RXO",13,1),RR)
..I ORID D
...S FDA(FN,RR_",",.02)=+ORID
...S ORITM=$$VALUE^ORCSAVE2(+ORID,"ORDERABLE")
...S:ORITM FDA(FN,RR_",",1.1)=ORITM
...S FDA(FN,RR_",",.03)=1
...S FDA(FN,RR_",",1.3)=PRV
...S FDA(FN,RR_",",1.2)=DFN ; Patient IEN
...S FDA(FN,RR_",",.11)=MATCHK
...D FILE^DIE("K","FDA")
...;MERGE DATA FROM ORDER RESPONSE LIST TO REFILL REQUEST RESPONSE LIST
...K ^APSPRREQ(RR,4.5)
...M ^APSPRREQ(RR,4.5)=^OR(100,ORID,4.5)
...S $P(^APSPRREQ(RR,4.5,0),U,2)="9009033.913A"
..E D
...N DATA
...S MATCHK=MATCHK_"Z"
...S FDA(FN,RR_",",.03)=0 ;9 ;PLS
...S FDA(FN,RR_",",.11)=MATCHK ;PLS
...D FILE^DIE("K","FDA")
...D UPTRRACT^APSPES3(RR,$P(ORID,U,2))
.E D
..;Store the data but send it to the queue
..S:ORITM FDA(FN,RR_",",1.1)=ORITM
..I +PRV S FDA(FN,RR_",",1.3)=PRV
..I +DFN S FDA(FN,RR_",",1.2)=DFN ; Patient IEN
..S FDA(FN,RR_",",.11)=MATCHK
..S FDA(FN,RR_",",.03)=0
..D FILE^DIE("K","FDA")
E D
.N HL7PON,ERRFLG
.S HL7PON=$$RXIEN(HLMSGIEN,1) ;Get PON sent in HL7 request
.I HL7PON?1.N,'(MATCHK["O") S ERRFLG=1
.S:$G(ORITM) FDA(FN,RR_",",1.1)=ORITM
.I +$G(DFN) S FDA(FN,RR_",",1.2)=DFN ; Patient IEN
.I +$G(PRV) S FDA(FN,RR_",",1.3)=PRV ; Provider IEN
.S FDA(FN,RR_",",.03)=$S($G(ERRFLG):9,1:0)
.S FDA(FN,RR_",",.11)=MATCHK
.D FILE^DIE("K","FDA")
.I $G(ERRFLG) D
..D UPTRRACT^APSPES3(RR,"PON does not match our records")
..D ERR900^APSPES4(RR,"PON does not match our records")
Q
SET(ARY,V,F,C,S,R) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
; Add entry to REFILL REQUEST file
ADDRR(MSGIEN) ; EP -
N FDA,FN,I,MSGID,ERR,IENS,SPI,RXIEN,DAYS,ACTSPI,NOTES
N FILLS,HMSG,PHARM,SSNUM,DXCODE,DX,FIEN,DAW
S FN=9009033.91,I="+1,",DFN=0,FIEN=0
S FDA(FN,I,.01)=$$GET1^DIQ(778,MSGIEN,.01) ; Message ID
S FDA(FN,I,.04)=$$GET1^DIQ(778,MSGIEN,.16,"I") ; Message D/T
S FDA(FN,I,.05)=MSGIEN ; HLO Message IEN
S FDA(FN,I,.07)=$$NOW^XLFDT() ; Last Update D/T
;Check for PON
S RXIEN=$$RXIEN^APSPES2(MSGIEN)
S:RXIEN MATCHK=MATCHK_"O"
;Patient check for matching pts
S:'DFN DFN=$$HRCNF^APSPFUNC($$GETVAL(MSGIEN,"PID",3,1))
I DFN=-1 D
.I 'RXIEN S DFN=$$CHKNME^APSPES4(MSGIEN) ;See if pt in PID segment is in file 2
.E D
..;check the pt in the order against the pt in the PID segment
..S DFN=$$GET1^DIQ(52,RXIEN,2,"I")
..S DFN=$$CHKOPT^APSPES4(DFN)
I +DFN S MATCHK=MATCHK_"P" ;Patients match
;Medication check
I RXIEN D
.S ORITM=$$CHKDRG^APSPES4(MSGIEN,RXIEN) ;Check the drug in the message
E D
.S ORITM=$$FNDORD^APSPES4(MSGIEN) ;Try and find the pharmacy orderable item for mapping in the queue
I +ORITM S MATCHK=MATCHK_"M" ;Drugs match
;Provider check
S SPI=$$GETVAL(MSGIEN,"ORC",12,1)
S PRV=$$FIND1^DIC(200,,"O",SPI,"ASPI")
S ACTSPI=1
I +PRV S ACTSPI=$$EFF(PRV)
I 'RXIEN&(+PRV)&(+ACTSPI) S MATCHK=MATCHK_"D"
I +RXIEN&(+PRV)&(+ACTSPI)&(PRV=$$GET1^DIQ(52,RXIEN,4,"I")) S MATCHK=MATCHK_"D"
S SSNUM=$$GETVAL(MSGIEN,"ORC",3,1)
S FILLS=$$GETVAL(MSGIEN,"RXO",13,1) ;Number of fills requested
I FILLS=""!(FILLS=0) S FILLS=1
S:RXIEN FDA(FN,I,.06)=RXIEN ; Original Prescription
S PHARM=$$GETVAL(MSGIEN,"RXE",40,1)
S:PHARM PHARM=$$FIND1^DIC(9009033.9,,"O",PHARM,"C")
S:PHARM FDA(FN,I,1.7)=PHARM
S DAYS=$$GETVAL(MSGIEN,"ORC",7,3) ; Days Supply
I +DAYS=0 S DAYS=$E(DAYS,2,$L(DAYS))
S DAW=$$GETVAL(MSGIEN,"RXO",9,1) ; DAW
S DAW=$S(DAW="G":0,DAW="T":0,1:1)
S FDA(FN,I,1.5)=+DAYS
S FDA(FN,I,1.4)=$$GETVAL(MSGIEN,"RXO",11,1) ; Quantity
S FDA(FN,I,1.9)=FILLS ; Number of fills
S FDA(FN,I,.1)=SSNUM ; Surescripts number
S FDA(FN,I,1.12)=DAW
;Add Diagnosis
S DXCODE=$$GETVAL(MSGIEN,"DG1",3,1)
S DX=$$GETVAL(MSGIEN,"DG1",3,2)
I DX=""&(DXCODE'="") D
.I $$AICD^BGOUTL2 S DX=$P($$ICDDX^ICDEX(DXCODE,DT),U,4)
.E S DX=$P($$ICDDX^ICDCODE(DXCODE,DT),U,4)
S FDA(FN,I,7.1)=DX
S FDA(FN,I,7.2)=DXCODE
;Add Notes to Pharmacist
S NOTES=$$GETVAL(MSGIEN,"RXO",6,2)
S FDA(FN,I,4.1)=NOTES
S FIEN=$$CHKSSNUM^APSPES4(SSNUM)
S FDA(FN,I,.03)=$S(FIEN:8,1:0) ; Status
D UPDATE^DIE(,"FDA","IENS","ERR")
;TODO - PROCESS ERR
;TODO - POPULATE OTHER FIELDS
K ERR
S I=+IENS(1)_","
D GETHMSG(MSGIEN,.HMSG)
S FDA(FN,I,5)=HMSG ; HL7 Message
D FILE^DIE("K","FDA","ERR")
D SIG(+IENS(1))
D DOSES(+IENS(1)) ;Add medication instructions multiple
I FIEN D
.D SETDUP^APSPES4(FIEN,+IENS(1))
.N S
.S S=$$GET1^DIQ(9009033.91,FIEN,.03,"I") ;Status
.I S=2!(S=3)!(S=5) D
..D NOTIF^APSPES4(,"Duplicate SS Request received","DUP:"_+IENS(1),$$GET1^DIQ(9009033.91,FIEN,1.2,"I"),$$GET1^DIQ(9009033.91,FIEN,1.3,"I"))
Q +$G(IENS(1))
; Extract data from segment
; Input: MSG - Message ien
; SEG - Segment name
; FLD - Field #
; OFF - Offset in field (default to 1)
GETVAL(MSG,SEG,FLD,OFF) ;EP -
N DATA,HLMSTATE,ARY,SEGIEN,SEGARY
S OFF=$G(OFF,1)
D PARSE(.DATA,MSG,.HLMSTATE)
Q:'$D(DATA) ""
S SEGIEN=$$FSEGIEN^APSPES1(.DATA,SEG)
Q:'SEGIEN ""
M SEGARY=DATA(SEGIEN)
Q $$GET^HLOPRS(.SEGARY,FLD,OFF)
DOSES(IEN) ;Get dosage fields
N HLMSG,HLDATA,APSPORC,SEG,CNT,I,FDA,AIEN,ERR,FN,MUL,N,D,RTE,ROUTE,TYPE,FORM,FORMT,CONJ,DUR
S HLMSG=$$GHLDAT^APSPESG(IEN)
S APSPORC=$$GETSEG^APSPESG(.HLDATA,"ORC")
S SEG=$P(APSPORC,"|",8)
S CNT=$L(SEG,"~")
S FN=9009033.912
F I=2:1:CNT D
.S MUL=$P(SEG,"~",I)
.S AIEN="+"_I_","_IEN_","
.S FDA(FN,AIEN,1.3)=$P(MUL,"^",1)
.S DUR=$P(MUL,"^",3)
.I DUR="INDEF" S DUR=""
.S N=$E(DUR,1,1)
.S D=$E(DUR,2,$L(DUR))
.S DUR=D_N
.S FDA(FN,AIEN,1.5)=DUR
.S FDA(FN,AIEN,1.1)=$P(MUL,"^",8)
.S FDA(FN,AIEN,1.8)=$P(MUL,"^",2)
.I CNT>2 D
..S CONJ=$P(MUL,"^",9)
..S FDA(FN,AIEN,1.6)=$S(CONJ="S":"T",1:"A")
.;Get the dose type
.S TYPE=$$GETVAL(MSGIEN,"RXO",12,1)
.S FORMT=""
.I TYPE'="" D
..S FORM=$O(^APSPNCP(9009033.7,"D",TYPE,""))
..I FORM'="" S FORMT=$P($G(^APSPNCP(9009033.7,FORM,0)),U,2)
.S FDA(FN,AIEN,.01)=$P(MUL,"^",8)_"&"_$P(MUL,"^",1)_"&&"_FORMT_"&"_$P(MUL,"^",8)_$P(MUL,"^",1)
.;Lookup the route
.S RTE=""
.S ROUTE=$$GETVAL(MSGIEN,"RXR",1,1)
.I ROUTE'="" S RTE=$O(^PS(51.2,"B",ROUTE,""))
.S FDA(FN,AIEN,1.7)=RTE
.D UPDATE^DIE(,"FDA","AIEN","ERR")
.K FDA,ERR
Q
SIG(IEN) ;Store sig
N FN,FDA,AIEN,ERR,X,X1,X2
S X2=""
S FN=9009033.913
S AIEN="+1,"_IEN_","
S X=$$GETVAL(MSGIEN,"RXO",7,2) ; SIG
I $L(X)>200 S X1=$E(X,1,200),X2=$E(X,201,$L(X))
E S X1=X
S FDA(FN,AIEN,.01)=X1
D UPDATE^DIE(,"FDA","AIEN","ERR")
I X2'="" D
.S FDA(FN,AIEN,.01)=X2
.D UPDATE^DIE(,"FDA","AIEN","ERR")
K ERR
Q
DEA(DRUG) ; Return DEA value
N DEA
S DEA=+$$GET1^DIQ(50,DRUG,3)
Q DEA
DEACLS(DEA,CLS) ; Return boolean value for comparison
Q CLS[DEA
;
PREPPTXT(RET,RRIEN) ; Return prepared text from Pharmacy
N M,C
S RRIEN=$G(RRIEN,0)
S M=$P(^APSPRREQ(RRIEN,0),U,5)
S @RET@(1)="Pharmacy: "_$$GETVAL(M,"RXE",40,2)_" ("_$$FMTPHN($$GETVAL(M,"RXE",45))_")"
S @RET@(2)="Drug description: "_$$GETVAL(M,"RXO",1,2)
S @RET@(3)="Quantity: "_$$GETVAL(M,"RXO",11)_" "_$$GET1^DIQ(9009033.7,$$FIND1^DIC(9009033.7,,,$$GETVAL(M,"RXO",12)),1)
S @RET@(4)="Days Supply: "_$$GETVAL(M,"ORC",7,3)
S @RET@(5)="Sig-Directions: "_$$GETVAL(M,"RXO",7,2)
S @RET@(6)="Note: "_$$GETVAL(M,"RXO",6,2)
S @RET@(7)="Refills: "_+$$GETVAL(M,"RXO",13,1)
S @RET@(8)="Substitution allowed: "_$$ESUBST($$GETVAL(M,"RXO",9))
S @RET@(9)="Last fill date: "_$$FMTE^XLFDT($$FMDATE^HLFNC($$GETVAL(M,"ORC",27,1)),"5DZ0")
S @RET@(10)=" "
S @RET@(11)="Diagnosis: "_$$GETVAL(M,"DG1",3,2)
Q
; Return full HL7 message
GETHMSG(MSGIEN,DATA) ;EP
N MSG,SEG,CNT
S DATA=$NA(^TMP("REFREQ",$J))
K @DATA
Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG)
S CNT=1
S SEG(1)=MSG("HDR",1)_MSG("HDR",2)
D ADD(.SEG)
F Q:'$$HLNEXT^HLOMSG(.MSG,.SEG) D
.D ADD(.SEG)
Q
; Return external text for Substitution
ESUBST(VAL) ;
Q $S(VAL="N":"Not Authorized",VAL="T":"Allow therapeutic",1:"Allowed Generic")
I() ;EP -
S CNT=CNT+1
Q CNT
; Return external text for diagnosis
GETDIAG(MSG) ; EP -
N TXT,DATA,ARY,SEG,HLMSTATE,HDR,SEGIEN,SEGDG1
S TXT=""
I '$$STARTMSG^HLOPRS(.HLMSTATE,MSG,.HDR) Q
F Q:'$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG) D
.I $$GET^HLOPRS(.SEG,0)="DG1" D
..S TXT=$$GET^HLOPRS(.SEG,3,1)_" ("_$$GET^HLOPRS(.SEG,3,3)_")"
..I $L(TXT) S C=C+1,@RET@(C)=TXT
Q DX
; Add data to array
ADD(SEG) ; EP -
N I
S I=0 F S I=$O(SEG(I)) Q:'I S @DATA@($$I())=SEG(I)
S @DATA@($$I())=""
Q
ADD1(SEG) ;
N QUIT,I,J,LINE
S QUIT=0
S (I,J)=1
S LINE(1)=$E(SEG(1),1,255),SEG(1)=$E(SEG(1),81,9999)
I SEG(1)="" K SEG(1)
D SHIFT(.I,.J)
S @VALMAR@($$I,0)=LINE(1)
S I=1
F S I=$O(LINE(I)) Q:'I D
.S @VALMAR@($$I,0)=LINE(I)
Q
;
SHIFT(I,J) ;
I '$D(SEG(I)) S I=$O(SEG(0)) Q:'I
I $L(LINE(J))<255 D
.N LEN
.S LEN=$L(LINE(J))
.S LINE(J)=LINE(J)_$E(SEG(I),1,255-LEN)
.S SEG(I)=$E(SEG(I),256-LEN,9999)
.I SEG(I)="" K SEG(I)
E D
.S J=J+1
.S LINE(J)="-"
D SHIFT(.I,.J)
Q
; Return formatted phone number
FMTPHN(X) ;EP
N RES
I $E(X,1,10)?10N Q "("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_$S($L($E(X,11,20)):" "_$E(X,11,20),1:"")
I $E(X,1,7)?7N Q $E(X,1,3)_"-"_$E(X,4,7)_" "_$E(8,20)
I X?10N1" ".6UN Q "("_$E(X,1,3)_")"_$E(X,4,6)_"-"_$E(X,7,10)_$S($L($E(X,11,20)):" "_$E(X,11,20),1:"")
I X?3N1"-"3N1"-"4N.1" ".A Q "("_$E(X,1,3)_")"_$E(X,5,12)_" "_$E(X,13,20)
I X?3N1"-"4N Q X
I X?3N1"-"4N.1" ".6UN Q X
Q X
; Check status of APSP REFIIL REQUEST entry
; Input: IEN - IEN
; STA - Status to check (if not passed, set to -1 and return status value)
RREQSTAT(DATA,IEN,STA) ; EP -
S RES=$P($G(^APSPRREQ(IEN,0)),U,3)
S:'$L($G(STA)) STA=-1
S DATA=$S(STA=-1:RES,1:RES=STA)
Q
EFF(PRV) ;See if SPI is ACTIVE
N EFF,IN
S IN=1
S EFF=9999999 F S EFF=$O(^VA(200,PRV,"SPISTATUS",EFF),-1) Q:'+EFF D
.S IN=$P($G(^VA(200,PRV,"SPISTATUS",EFF,0)),U,2)
Q IN
ACK(HLMSGIEN,MSGTXT) ; Generate APP Ack
N PARMS,ACK,ERR,OCC,DNYC
S PARMS("ACK CODE")="AE"
S PARMS("ERROR MESSAGE")=MSGTXT
D PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
I $$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR) D
.S OCC="UF",DNYC="AF"
.D SETACK^APSPES3
.I '$$SENDACK^HLOAPI2(.ACK,.ERR)&(+RR) D UPTRRACT^APSPES3(RR,$G(ERR,"There was a problem generating the HL7 message"))
Q
APSPES2 ;IHS/MSC/PLS - SureScripts HL7 interface - con't;23-Mar-2015 09:06;DU
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1008,1011,1016,1018**;Sep 23, 2004;Build 21
+2 ; Return array of message data
+3 ; Input: MIEN - IEN to HLO MESSAGES and HLO MESSAGE BODY files
+4 ; Output: DATA
+5 ; HLMSTATE
PARSE(DATA,MIEN,HLMSTATE) ;EP
+1 NEW SEG,CNT
+2 IF '$$STARTMSG^HLOPRS(.HLMSTATE,MIEN)
QUIT
+3 MERGE DATA("HDR")=HLMSTATE("HDR")
+4 SET CNT=0
+5 FOR
IF '$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG)
QUIT
Begin DoDot:1
+6 SET CNT=CNT+1
+7 MERGE DATA(CNT)=SEG
End DoDot:1
+8 QUIT
+9 ; Process incoming RDS message
DISP ;EP
+1 NEW DATA,ARY,SEGORC,SEGIEN,SEGRXD,ERR,RET
+2 NEW DRG,DCODE,DCODEQ,PVDIEN,DSPNUM,RXIEN
+3 IF '$GET(HLMSGIEN)
QUIT
+4 DO PARSE(.DATA,HLMSGIEN,.HLMSTATE)
+5 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ORC")
+6 IF 'SEGIEN
QUIT 0
+7 MERGE SEGORC=DATA(SEGIEN)
+8 IF $$GET^HLOPRS(.SEGORC,1,1)'="OK"
QUIT
+9 SET PVDIEN=$$GET^HLOPRS(.SEGORC,10,1)
+10 SET RXIEN=$$GET^HLOPRS(.SEGORC,2,1)
+11 IF 'RXIEN
QUIT
+12 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"RXD")
+13 IF 'SEGIEN
QUIT
+14 MERGE SEGRXD=DATA(SEGIEN)
+15 SET DSPNUM=$$GET^HLOPRS(.SEGRXD,1)
+16 IF 'DSPNUM
QUIT
+17 ;Adjust fill offset - original = 0
SET DSPNUM=DSPNUM-1
+18 SET DCODE=$$GET^HLOPRS(.SEGRXD,2,1)
+19 SET DRG=$$GET^HLOPRS(.SEGRXD,2,2)
+20 SET DCODEQ=$$GET^HLOPRS(.SEGRXD,2,3)
+21 SET ARY("REASON")="X"
+22 SET ARY("TYPE")="U"
+23 ; adjust for 6=partial
SET ARY("RX REF")=$SELECT(DSPNUM>5:DSPNUM+1,1:DSPNUM)
+24 SET ARY("COM")="DDrg:"_DRG_$SELECT($LENGTH(DCODE):" ("_DCODEQ_":"_DCODE_")",1:"")
+25 SET ARY("USER")=PVDIEN
+26 DO UPTLOG^APSPFNC2(.RET,RXIEN,0,.ARY)
+27 IF DATA("HDR","APP ACK TYPE")="AL"
Begin DoDot:1
+28 ; Generate APP Ack
+29 NEW PARMS,ACK,ERR
+30 SET PARMS("ACK CODE")="AA"
+31 IF '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR)
WRITE !,ERR
QUIT
+32 IF '$$SENDACK^HLOAPI2(.ACK,.ERR)
WRITE !,ERR
QUIT
End DoDot:1
+33 QUIT
DSP ;
+1 NEW HLMSGIEN,HLMSTATE,PARMS
+2 SET HLMSGIEN=200000000001
+3 DO PARSE(.DATA,HLMSGIEN,.HLMSTATE)
+4 SET PARMS("ACK CODE")="AA"
+5 IF '$$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR)
WRITE !,ERR
QUIT
+6 IF '$$SENDACK^HLOAPI2(.ACK,.ERR)
WRITE !,ERR
QUIT
+7 QUIT
+8 ; Send bulletin
BULL(XMSUB,XMDUZ,WHO,MSG) ;EP
+1 NEW XMY,XMTEXT
+2 MERGE XMY=WHO
+3 SET XMTEXT="MSG("
+4 DO ^XMD
+5 QUIT
+6 ; Return Ordering Provider for HL7 Message
OPRV(MSGIEN) ; EP
+1 NEW RXIEN,VAL
+2 SET VAL=0
+3 SET RXIEN=+$$RXIEN(MSGIEN)
+4 IF 'RXIEN
QUIT ""
+5 QUIT +$PIECE($GET(^PSRX(RXIEN,0)),U,16)
+6 ; Return RX IEN
+7 ; Input: MSGIEN - HLO Message IEN
+8 ; TGL - default to 0, 1=return numeric value in HL7 message
RXIEN(MSGIEN,TGL) ; EP
+1 NEW RET,RXN
+2 SET TGL=$GET(TGL,0)
+3 DO PARSE(.DATA,MSGIEN,.HLMSTATE)
+4 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,"ORC")
+5 IF 'SEGIEN
QUIT ""
+6 MERGE SEGORC=DATA(SEGIEN)
+7 SET RXN=$$GET^HLOPRS(.SEGORC,2,1)
+8 SET RET=$SELECT(TGL:RXN,$DATA(^PSRX(+RXN,0)):+RXN,1:0)
+9 QUIT RET
+10 ; Return Pharmacy Info for Activity Log
+11 ; Input - RXIEN - Prescription IEN
PHMINFO(RXIEN) ; EP -
+1 NEW PHM
+2 SET PHM=$$GPHM^APSPES1(RXIEN)
+3 IF 'PHM
QUIT "UNKNOWN"
+4 QUIT $$GET1^DIQ(9009033.9,PHM,.01)_" "_$$HLPHONE^HLFNC($$GET1^DIQ(9009033.9,PHM,2.1))
+5 ;
REFRES ; EP - Refill request callback
+1 ;Build response to Refill Request
+2 NEW DATA,PARMS,SEG,ACK,ARY,ERR,ORID,SEGRX0,REFILL,RR,ORITM,PRV,DFN
+3 NEW RXIEN,FN,DEA,MATCHK
+4 SET MATCHK=""
+5 DO PARSE^APSPES2(.DATA,$GET(HLMSGIEN),.HLMSTATE)
+6 ; Create entry in APSP REFILL REQUEST file
+7 ; If possible, generate order
+8 SET FN=9009033.91
+9 SET RR=$$ADDRR(+$GET(HLMSGIEN))
+10 ;Do not process duplicate record
IF $$GET1^DIQ(9009033.91,RR,.03,"I")=8
QUIT
+11 SET RXIEN=+$$GET1^DIQ(9009033.91,RR,.06,"I")
+12 SET DEA=$$DEA($PIECE($GET(^PSRX(RXIEN,0)),U,6))
+13 ;,'$$DEACLS(DEA,2) D
IF RR
IF RXIEN
Begin DoDot:1
+14 IF '$DATA(^PSRX(RXIEN,0))
Begin DoDot:2
+15 SET MATCHK=MATCHK_"Z"
End DoDot:2
QUIT
+16 ;Only allow automap if patient and provider match and there is an order
+17 IF MATCHK["P"&(MATCHK["D")
Begin DoDot:2
+18 SET ORID=$$GENRENEW^APSPES4(HLMSGIEN,RXIEN,$$GET1^DIQ(52,RXIEN,16,"I"),$$GETVAL(HLMSGIEN,"RXO",13,1),RR)
+19 IF ORID
Begin DoDot:3
+20 SET FDA(FN,RR_",",.02)=+ORID
+21 SET ORITM=$$VALUE^ORCSAVE2(+ORID,"ORDERABLE")
+22 IF ORITM
SET FDA(FN,RR_",",1.1)=ORITM
+23 SET FDA(FN,RR_",",.03)=1
+24 SET FDA(FN,RR_",",1.3)=PRV
+25 ; Patient IEN
SET FDA(FN,RR_",",1.2)=DFN
+26 SET FDA(FN,RR_",",.11)=MATCHK
+27 DO FILE^DIE("K","FDA")
+28 ;MERGE DATA FROM ORDER RESPONSE LIST TO REFILL REQUEST RESPONSE LIST
+29 KILL ^APSPRREQ(RR,4.5)
+30 MERGE ^APSPRREQ(RR,4.5)=^OR(100,ORID,4.5)
+31 SET $PIECE(^APSPRREQ(RR,4.5,0),U,2)="9009033.913A"
End DoDot:3
+32 IF '$TEST
Begin DoDot:3
+33 NEW DATA
+34 SET MATCHK=MATCHK_"Z"
+35 ;9 ;PLS
SET FDA(FN,RR_",",.03)=0
+36 ;PLS
SET FDA(FN,RR_",",.11)=MATCHK
+37 DO FILE^DIE("K","FDA")
+38 DO UPTRRACT^APSPES3(RR,$PIECE(ORID,U,2))
End DoDot:3
End DoDot:2
+39 IF '$TEST
Begin DoDot:2
+40 ;Store the data but send it to the queue
+41 IF ORITM
SET FDA(FN,RR_",",1.1)=ORITM
+42 IF +PRV
SET FDA(FN,RR_",",1.3)=PRV
+43 ; Patient IEN
IF +DFN
SET FDA(FN,RR_",",1.2)=DFN
+44 SET FDA(FN,RR_",",.11)=MATCHK
+45 SET FDA(FN,RR_",",.03)=0
+46 DO FILE^DIE("K","FDA")
End DoDot:2
End DoDot:1
+47 IF '$TEST
Begin DoDot:1
+48 NEW HL7PON,ERRFLG
+49 ;Get PON sent in HL7 request
SET HL7PON=$$RXIEN(HLMSGIEN,1)
+50 IF HL7PON?1.N
IF '(MATCHK["O")
SET ERRFLG=1
+51 IF $GET(ORITM)
SET FDA(FN,RR_",",1.1)=ORITM
+52 ; Patient IEN
IF +$GET(DFN)
SET FDA(FN,RR_",",1.2)=DFN
+53 ; Provider IEN
IF +$GET(PRV)
SET FDA(FN,RR_",",1.3)=PRV
+54 SET FDA(FN,RR_",",.03)=$SELECT($GET(ERRFLG):9,1:0)
+55 SET FDA(FN,RR_",",.11)=MATCHK
+56 DO FILE^DIE("K","FDA")
+57 IF $GET(ERRFLG)
Begin DoDot:2
+58 DO UPTRRACT^APSPES3(RR,"PON does not match our records")
+59 DO ERR900^APSPES4(RR,"PON does not match our records")
End DoDot:2
End DoDot:1
+60 QUIT
SET(ARY,V,F,C,S,R) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
+3 ; Add entry to REFILL REQUEST file
ADDRR(MSGIEN) ; EP -
+1 NEW FDA,FN,I,MSGID,ERR,IENS,SPI,RXIEN,DAYS,ACTSPI,NOTES
+2 NEW FILLS,HMSG,PHARM,SSNUM,DXCODE,DX,FIEN,DAW
+3 SET FN=9009033.91
SET I="+1,"
SET DFN=0
SET FIEN=0
+4 ; Message ID
SET FDA(FN,I,.01)=$$GET1^DIQ(778,MSGIEN,.01)
+5 ; Message D/T
SET FDA(FN,I,.04)=$$GET1^DIQ(778,MSGIEN,.16,"I")
+6 ; HLO Message IEN
SET FDA(FN,I,.05)=MSGIEN
+7 ; Last Update D/T
SET FDA(FN,I,.07)=$$NOW^XLFDT()
+8 ;Check for PON
+9 SET RXIEN=$$RXIEN^APSPES2(MSGIEN)
+10 IF RXIEN
SET MATCHK=MATCHK_"O"
+11 ;Patient check for matching pts
+12 IF 'DFN
SET DFN=$$HRCNF^APSPFUNC($$GETVAL(MSGIEN,"PID",3,1))
+13 IF DFN=-1
Begin DoDot:1
+14 ;See if pt in PID segment is in file 2
IF 'RXIEN
SET DFN=$$CHKNME^APSPES4(MSGIEN)
+15 IF '$TEST
Begin DoDot:2
+16 ;check the pt in the order against the pt in the PID segment
+17 SET DFN=$$GET1^DIQ(52,RXIEN,2,"I")
+18 SET DFN=$$CHKOPT^APSPES4(DFN)
End DoDot:2
End DoDot:1
+19 ;Patients match
IF +DFN
SET MATCHK=MATCHK_"P"
+20 ;Medication check
+21 IF RXIEN
Begin DoDot:1
+22 ;Check the drug in the message
SET ORITM=$$CHKDRG^APSPES4(MSGIEN,RXIEN)
End DoDot:1
+23 IF '$TEST
Begin DoDot:1
+24 ;Try and find the pharmacy orderable item for mapping in the queue
SET ORITM=$$FNDORD^APSPES4(MSGIEN)
End DoDot:1
+25 ;Drugs match
IF +ORITM
SET MATCHK=MATCHK_"M"
+26 ;Provider check
+27 SET SPI=$$GETVAL(MSGIEN,"ORC",12,1)
+28 SET PRV=$$FIND1^DIC(200,,"O",SPI,"ASPI")
+29 SET ACTSPI=1
+30 IF +PRV
SET ACTSPI=$$EFF(PRV)
+31 IF 'RXIEN&(+PRV)&(+ACTSPI)
SET MATCHK=MATCHK_"D"
+32 IF +RXIEN&(+PRV)&(+ACTSPI)&(PRV=$$GET1^DIQ(52,RXIEN,4,"I"))
SET MATCHK=MATCHK_"D"
+33 SET SSNUM=$$GETVAL(MSGIEN,"ORC",3,1)
+34 ;Number of fills requested
SET FILLS=$$GETVAL(MSGIEN,"RXO",13,1)
+35 IF FILLS=""!(FILLS=0)
SET FILLS=1
+36 ; Original Prescription
IF RXIEN
SET FDA(FN,I,.06)=RXIEN
+37 SET PHARM=$$GETVAL(MSGIEN,"RXE",40,1)
+38 IF PHARM
SET PHARM=$$FIND1^DIC(9009033.9,,"O",PHARM,"C")
+39 IF PHARM
SET FDA(FN,I,1.7)=PHARM
+40 ; Days Supply
SET DAYS=$$GETVAL(MSGIEN,"ORC",7,3)
+41 IF +DAYS=0
SET DAYS=$EXTRACT(DAYS,2,$LENGTH(DAYS))
+42 ; DAW
SET DAW=$$GETVAL(MSGIEN,"RXO",9,1)
+43 SET DAW=$SELECT(DAW="G":0,DAW="T":0,1:1)
+44 SET FDA(FN,I,1.5)=+DAYS
+45 ; Quantity
SET FDA(FN,I,1.4)=$$GETVAL(MSGIEN,"RXO",11,1)
+46 ; Number of fills
SET FDA(FN,I,1.9)=FILLS
+47 ; Surescripts number
SET FDA(FN,I,.1)=SSNUM
+48 SET FDA(FN,I,1.12)=DAW
+49 ;Add Diagnosis
+50 SET DXCODE=$$GETVAL(MSGIEN,"DG1",3,1)
+51 SET DX=$$GETVAL(MSGIEN,"DG1",3,2)
+52 IF DX=""&(DXCODE'="")
Begin DoDot:1
+53 IF $$AICD^BGOUTL2
SET DX=$PIECE($$ICDDX^ICDEX(DXCODE,DT),U,4)
+54 IF '$TEST
SET DX=$PIECE($$ICDDX^ICDCODE(DXCODE,DT),U,4)
End DoDot:1
+55 SET FDA(FN,I,7.1)=DX
+56 SET FDA(FN,I,7.2)=DXCODE
+57 ;Add Notes to Pharmacist
+58 SET NOTES=$$GETVAL(MSGIEN,"RXO",6,2)
+59 SET FDA(FN,I,4.1)=NOTES
+60 SET FIEN=$$CHKSSNUM^APSPES4(SSNUM)
+61 ; Status
SET FDA(FN,I,.03)=$SELECT(FIEN:8,1:0)
+62 DO UPDATE^DIE(,"FDA","IENS","ERR")
+63 ;TODO - PROCESS ERR
+64 ;TODO - POPULATE OTHER FIELDS
+65 KILL ERR
+66 SET I=+IENS(1)_","
+67 DO GETHMSG(MSGIEN,.HMSG)
+68 ; HL7 Message
SET FDA(FN,I,5)=HMSG
+69 DO FILE^DIE("K","FDA","ERR")
+70 DO SIG(+IENS(1))
+71 ;Add medication instructions multiple
DO DOSES(+IENS(1))
+72 IF FIEN
Begin DoDot:1
+73 DO SETDUP^APSPES4(FIEN,+IENS(1))
+74 NEW S
+75 ;Status
SET S=$$GET1^DIQ(9009033.91,FIEN,.03,"I")
+76 IF S=2!(S=3)!(S=5)
Begin DoDot:2
+77 DO NOTIF^APSPES4(,"Duplicate SS Request received","DUP:"_+IENS(1),$$GET1^DIQ(9009033.91,FIEN,1.2,"I"),$$GET1^DIQ(9009033.91,FIEN,1.3,"I"))
End DoDot:2
End DoDot:1
+78 QUIT +$GET(IENS(1))
+79 ; Extract data from segment
+80 ; Input: MSG - Message ien
+81 ; SEG - Segment name
+82 ; FLD - Field #
+83 ; OFF - Offset in field (default to 1)
GETVAL(MSG,SEG,FLD,OFF) ;EP -
+1 NEW DATA,HLMSTATE,ARY,SEGIEN,SEGARY
+2 SET OFF=$GET(OFF,1)
+3 DO PARSE(.DATA,MSG,.HLMSTATE)
+4 IF '$DATA(DATA)
QUIT ""
+5 SET SEGIEN=$$FSEGIEN^APSPES1(.DATA,SEG)
+6 IF 'SEGIEN
QUIT ""
+7 MERGE SEGARY=DATA(SEGIEN)
+8 QUIT $$GET^HLOPRS(.SEGARY,FLD,OFF)
DOSES(IEN) ;Get dosage fields
+1 NEW HLMSG,HLDATA,APSPORC,SEG,CNT,I,FDA,AIEN,ERR,FN,MUL,N,D,RTE,ROUTE,TYPE,FORM,FORMT,CONJ,DUR
+2 SET HLMSG=$$GHLDAT^APSPESG(IEN)
+3 SET APSPORC=$$GETSEG^APSPESG(.HLDATA,"ORC")
+4 SET SEG=$PIECE(APSPORC,"|",8)
+5 SET CNT=$LENGTH(SEG,"~")
+6 SET FN=9009033.912
+7 FOR I=2:1:CNT
Begin DoDot:1
+8 SET MUL=$PIECE(SEG,"~",I)
+9 SET AIEN="+"_I_","_IEN_","
+10 SET FDA(FN,AIEN,1.3)=$PIECE(MUL,"^",1)
+11 SET DUR=$PIECE(MUL,"^",3)
+12 IF DUR="INDEF"
SET DUR=""
+13 SET N=$EXTRACT(DUR,1,1)
+14 SET D=$EXTRACT(DUR,2,$LENGTH(DUR))
+15 SET DUR=D_N
+16 SET FDA(FN,AIEN,1.5)=DUR
+17 SET FDA(FN,AIEN,1.1)=$PIECE(MUL,"^",8)
+18 SET FDA(FN,AIEN,1.8)=$PIECE(MUL,"^",2)
+19 IF CNT>2
Begin DoDot:2
+20 SET CONJ=$PIECE(MUL,"^",9)
+21 SET FDA(FN,AIEN,1.6)=$SELECT(CONJ="S":"T",1:"A")
End DoDot:2
+22 ;Get the dose type
+23 SET TYPE=$$GETVAL(MSGIEN,"RXO",12,1)
+24 SET FORMT=""
+25 IF TYPE'=""
Begin DoDot:2
+26 SET FORM=$ORDER(^APSPNCP(9009033.7,"D",TYPE,""))
+27 IF FORM'=""
SET FORMT=$PIECE($GET(^APSPNCP(9009033.7,FORM,0)),U,2)
End DoDot:2
+28 SET FDA(FN,AIEN,.01)=$PIECE(MUL,"^",8)_"&"_$PIECE(MUL,"^",1)_"&&"_FORMT_"&"_$PIECE(MUL,"^",8)_$PIECE(MUL,"^",1)
+29 ;Lookup the route
+30 SET RTE=""
+31 SET ROUTE=$$GETVAL(MSGIEN,"RXR",1,1)
+32 IF ROUTE'=""
SET RTE=$ORDER(^PS(51.2,"B",ROUTE,""))
+33 SET FDA(FN,AIEN,1.7)=RTE
+34 DO UPDATE^DIE(,"FDA","AIEN","ERR")
+35 KILL FDA,ERR
End DoDot:1
+36 QUIT
SIG(IEN) ;Store sig
+1 NEW FN,FDA,AIEN,ERR,X,X1,X2
+2 SET X2=""
+3 SET FN=9009033.913
+4 SET AIEN="+1,"_IEN_","
+5 ; SIG
SET X=$$GETVAL(MSGIEN,"RXO",7,2)
+6 IF $LENGTH(X)>200
SET X1=$EXTRACT(X,1,200)
SET X2=$EXTRACT(X,201,$LENGTH(X))
+7 IF '$TEST
SET X1=X
+8 SET FDA(FN,AIEN,.01)=X1
+9 DO UPDATE^DIE(,"FDA","AIEN","ERR")
+10 IF X2'=""
Begin DoDot:1
+11 SET FDA(FN,AIEN,.01)=X2
+12 DO UPDATE^DIE(,"FDA","AIEN","ERR")
End DoDot:1
+13 KILL ERR
+14 QUIT
DEA(DRUG) ; Return DEA value
+1 NEW DEA
+2 SET DEA=+$$GET1^DIQ(50,DRUG,3)
+3 QUIT DEA
DEACLS(DEA,CLS) ; Return boolean value for comparison
+1 QUIT CLS[DEA
+2 ;
PREPPTXT(RET,RRIEN) ; Return prepared text from Pharmacy
+1 NEW M,C
+2 SET RRIEN=$GET(RRIEN,0)
+3 SET M=$PIECE(^APSPRREQ(RRIEN,0),U,5)
+4 SET @RET@(1)="Pharmacy: "_$$GETVAL(M,"RXE",40,2)_" ("_$$FMTPHN($$GETVAL(M,"RXE",45))_")"
+5 SET @RET@(2)="Drug description: "_$$GETVAL(M,"RXO",1,2)
+6 SET @RET@(3)="Quantity: "_$$GETVAL(M,"RXO",11)_" "_$$GET1^DIQ(9009033.7,$$FIND1^DIC(9009033.7,,,$$GETVAL(M,"RXO",12)),1)
+7 SET @RET@(4)="Days Supply: "_$$GETVAL(M,"ORC",7,3)
+8 SET @RET@(5)="Sig-Directions: "_$$GETVAL(M,"RXO",7,2)
+9 SET @RET@(6)="Note: "_$$GETVAL(M,"RXO",6,2)
+10 SET @RET@(7)="Refills: "_+$$GETVAL(M,"RXO",13,1)
+11 SET @RET@(8)="Substitution allowed: "_$$ESUBST($$GETVAL(M,"RXO",9))
+12 SET @RET@(9)="Last fill date: "_$$FMTE^XLFDT($$FMDATE^HLFNC($$GETVAL(M,"ORC",27,1)),"5DZ0")
+13 SET @RET@(10)=" "
+14 SET @RET@(11)="Diagnosis: "_$$GETVAL(M,"DG1",3,2)
+15 QUIT
+16 ; Return full HL7 message
GETHMSG(MSGIEN,DATA) ;EP
+1 NEW MSG,SEG,CNT
+2 SET DATA=$NAME(^TMP("REFREQ",$JOB))
+3 KILL @DATA
+4 IF '$$GETMSG^HLOMSG(MSGIEN,.MSG)
QUIT
+5 SET CNT=1
+6 SET SEG(1)=MSG("HDR",1)_MSG("HDR",2)
+7 DO ADD(.SEG)
+8 FOR
IF '$$HLNEXT^HLOMSG(.MSG,.SEG)
QUIT
Begin DoDot:1
+9 DO ADD(.SEG)
End DoDot:1
+10 QUIT
+11 ; Return external text for Substitution
ESUBST(VAL) ;
+1 QUIT $SELECT(VAL="N":"Not Authorized",VAL="T":"Allow therapeutic",1:"Allowed Generic")
I() ;EP -
+1 SET CNT=CNT+1
+2 QUIT CNT
+3 ; Return external text for diagnosis
GETDIAG(MSG) ; EP -
+1 NEW TXT,DATA,ARY,SEG,HLMSTATE,HDR,SEGIEN,SEGDG1
+2 SET TXT=""
+3 IF '$$STARTMSG^HLOPRS(.HLMSTATE,MSG,.HDR)
QUIT
+4 FOR
IF '$$NEXTSEG^HLOPRS(.HLMSTATE,.SEG)
QUIT
Begin DoDot:1
+5 IF $$GET^HLOPRS(.SEG,0)="DG1"
Begin DoDot:2
+6 SET TXT=$$GET^HLOPRS(.SEG,3,1)_" ("_$$GET^HLOPRS(.SEG,3,3)_")"
+7 IF $LENGTH(TXT)
SET C=C+1
SET @RET@(C)=TXT
End DoDot:2
End DoDot:1
+8 QUIT DX
+9 ; Add data to array
ADD(SEG) ; EP -
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(SEG(I))
IF 'I
QUIT
SET @DATA@($$I())=SEG(I)
+3 SET @DATA@($$I())=""
+4 QUIT
ADD1(SEG) ;
+1 NEW QUIT,I,J,LINE
+2 SET QUIT=0
+3 SET (I,J)=1
+4 SET LINE(1)=$EXTRACT(SEG(1),1,255)
SET SEG(1)=$EXTRACT(SEG(1),81,9999)
+5 IF SEG(1)=""
KILL SEG(1)
+6 DO SHIFT(.I,.J)
+7 SET @VALMAR@($$I,0)=LINE(1)
+8 SET I=1
+9 FOR
SET I=$ORDER(LINE(I))
IF 'I
QUIT
Begin DoDot:1
+10 SET @VALMAR@($$I,0)=LINE(I)
End DoDot:1
+11 QUIT
+12 ;
SHIFT(I,J) ;
+1 IF '$DATA(SEG(I))
SET I=$ORDER(SEG(0))
IF 'I
QUIT
+2 IF $LENGTH(LINE(J))<255
Begin DoDot:1
+3 NEW LEN
+4 SET LEN=$LENGTH(LINE(J))
+5 SET LINE(J)=LINE(J)_$EXTRACT(SEG(I),1,255-LEN)
+6 SET SEG(I)=$EXTRACT(SEG(I),256-LEN,9999)
+7 IF SEG(I)=""
KILL SEG(I)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET J=J+1
+10 SET LINE(J)="-"
End DoDot:1
+11 DO SHIFT(.I,.J)
+12 QUIT
+13 ; Return formatted phone number
FMTPHN(X) ;EP
+1 NEW RES
+2 IF $EXTRACT(X,1,10)?10N
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_$SELECT($LENGTH($EXTRACT(X,11,20)):" "_$EXTRACT(X,11,20),1:"")
+3 IF $EXTRACT(X,1,7)?7N
QUIT $EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,7)_" "_$EXTRACT(8,20)
+4 IF X?10N1" ".6UN
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,4,6)_"-"_$EXTRACT(X,7,10)_$SELECT($LENGTH($EXTRACT(X,11,20)):" "_$EXTRACT(X,11,20),1:"")
+5 IF X?3N1"-"3N1"-"4N.1" ".A
QUIT "("_$EXTRACT(X,1,3)_")"_$EXTRACT(X,5,12)_" "_$EXTRACT(X,13,20)
+6 IF X?3N1"-"4N
QUIT X
+7 IF X?3N1"-"4N.1" ".6UN
QUIT X
+8 QUIT X
+9 ; Check status of APSP REFIIL REQUEST entry
+10 ; Input: IEN - IEN
+11 ; STA - Status to check (if not passed, set to -1 and return status value)
RREQSTAT(DATA,IEN,STA) ; EP -
+1 SET RES=$PIECE($GET(^APSPRREQ(IEN,0)),U,3)
+2 IF '$LENGTH($GET(STA))
SET STA=-1
+3 SET DATA=$SELECT(STA=-1:RES,1:RES=STA)
+4 QUIT
EFF(PRV) ;See if SPI is ACTIVE
+1 NEW EFF,IN
+2 SET IN=1
+3 SET EFF=9999999
FOR
SET EFF=$ORDER(^VA(200,PRV,"SPISTATUS",EFF),-1)
IF '+EFF
QUIT
Begin DoDot:1
+4 SET IN=$PIECE($GET(^VA(200,PRV,"SPISTATUS",EFF,0)),U,2)
End DoDot:1
+5 QUIT IN
ACK(HLMSGIEN,MSGTXT) ; Generate APP Ack
+1 NEW PARMS,ACK,ERR,OCC,DNYC
+2 SET PARMS("ACK CODE")="AE"
+3 SET PARMS("ERROR MESSAGE")=MSGTXT
+4 DO PARSE^APSPES2(.DATA,HLMSGIEN,.HLMSTATE)
+5 IF $$ACK^HLOAPI2(.HLMSTATE,.PARMS,.ACK,.ERR)
Begin DoDot:1
+6 SET OCC="UF"
SET DNYC="AF"
+7 DO SETACK^APSPES3
+8 IF '$$SENDACK^HLOAPI2(.ACK,.ERR)&(+RR)
DO UPTRRACT^APSPES3(RR,$GET(ERR,"There was a problem generating the HL7 message"))
End DoDot:1
+9 QUIT
