ORRDI1 ;SLC/JMH - RDI routines for API supporting CDS data; 3/24/05 2:31 [8/11/05 6:25am] ; 1/11/07 8:33am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
;
GET(DFN,DOMAIN) ;API for packages to call in order to get data from HDR for
; check if in OUTAGE state and quit if so
I $$DOWNXVAL^ORRDI2 D Q -1
.K ^XTMP("ORRDI",DOMAIN,DFN)
.S ^XTMP("ORRDI",DOMAIN,DFN,0)="^^-1"
; order checking purposes
N I,ORCACHE,ORRET,ORRECDT
;check if data was just retrieved a short time ago and if so return
S ORRECDT=$P($G(^XTMP("ORRDI",DOMAIN,DFN,0)),U)
S ORCACHE=$$GET^XPAR("SYS","OR RDI CACHE TIME")
I $$FMDIFF^XLFDT($$NOW^XLFDT,ORRECDT,2)<(60*ORCACHE),$P(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)>-1 S ORRET=$P(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)
;check if there has been an HDR down condition within last minute
I $$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^XTMP("ORRDI","PSOO",DFN,0)),U),2)<60,$P($G(^XTMP("ORRDI","PSOO",DFN,0)),U,3)<0 S ORRET=$P($G(^XTMP("ORRDI","PSOO",DFN,0)),U,3)
I $$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^XTMP("ORRDI","ART",DFN,0)),U),2)<60,$P($G(^XTMP("ORRDI","ART",DFN,0)),U,3)<0 S ORRET=$P($G(^XTMP("ORRDI","ART",DFN,0)),U,3)
;if data is not "fresh" then go get it
I '$L($G(ORRET)) D
.S ORRET=$$RETRIEVE(DFN,DOMAIN)
.I ORRET>-1 S ^XTMP("ORRDI","OUTAGE INFO","FAILURES")=0
.I ORRET'>-1 D
..Q:$P(ORRET,U,2)="PATIENT ICN NOT FOUND"
..S ^XTMP("ORRDI","OUTAGE INFO","FAILURES")=$$FAILXVAL^ORRDI2+1
..I $$FAILXVAL^ORRDI2'<$$FAILPVAL^ORRDI2 D
...S ^XTMP("ORRDI","OUTAGE INFO","DOWN")=1
...D SPAWN^ORRDI2
S $P(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)=ORRET
I ORRET<1 D
.N TEMP S TEMP=^XTMP("ORRDI",DOMAIN,DFN,0)
.K ^XTMP("ORRDI",DOMAIN,DFN)
.S ^XTMP("ORRDI",DOMAIN,DFN,0)=TEMP
Q ORRET
HAVEHDR() ;call to check if this system has an HDR to perform order checks
; against
;check parameter to see if there is an HDR and returns positive if so
I $$GET^XPAR("SYS","OR RDI HAVE HDR") Q 1
;returns negative because the parameter indicates there is no HDR
Q 0
RETRIEVE(DFN,DOMAIN) ;actually go get the data from CDS
K ^XTMP("ORRDI",DOMAIN,DFN)
N START,END,HLL,HLA,ORFS,ORCS,ORRS,ORES,ORSS
N Y,ORRSLT,ICN,WHATOUT,HLNEXT,HLNODE,HLQUIT,ORHLP,RET,HL,HLDOM,HLDONE1,HLECH,HLFS,HLINSTN,HLMTIEN,HLPARAM,HLQ,STATUS,PRE
S (ORFS,ORCS,ORRS,ORES,ORSS)=""
;S START=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),-120),END=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),485)
;set up what codes for specific domains
I DOMAIN="ART" S WHATOUT="039OC_AL:ALLERGIES"
I DOMAIN="PSOO" S WHATOUT="055OC_RXOP:PHARMACY ALL OUTPATIENT",START=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),-30)
;get patient identifier (ICN)
D SELECT^ORWPT(.Y,DFN)
S ICN=$P($G(Y),U,14)
I 'ICN Q -1_"^PATIENT ICN NOT FOUND"
;build HLA array with request HL7
S HLA("HLS",1)="SPR^XWBDRPC845-569716_0^T^ZREMOTE RPC^@SPR.4.2~003RPC017ORWRP REPORT TEXT&006RPCVER0010&007XWBPCNT0017&007XWBESSO066321214321\F\\F\\F\657\F"
S HLA("HLS",1,1)="\48102&007XWBDVER0011&006XWBSEC0043.14&002P10187369543;"_ICN_"&002P2"_WHATOUT_";1\S\RXOP;ORDV06;28;200&002P3000&002P4000&002P5000&002P600"_$L($G(START))_$G(START)_"&002P700"_$L($G(END))_$G(END)
S HLA("HLS",2)="RDF^1^@DSP.3~TX~300"
;set HLL("LINKS") node to specify receiver location
S HLL("LINKS",1)="ORRDI SUBSCRIBER^ORHDR"
S ORHLP("OPEN TIMEOUT")=10
S ORHLP("SUBSCRIBER")="^OR RDI SENDER^"_$P($$SITE^VASITE,U,3)_"^OR RDI RECEIVER^^^"
;call DIRECT^HLMA to send request
D DIRECT^HLMA("ORRDI EVENT","LM",1,.ORRSLT,,.ORHLP)
;set time stamp of the data
I $G(ORRSLT) S ^XTMP("ORRDI",DOMAIN,DFN,0)=$$NOW^XLFDT
;check if call failed
I $P($G(ORRSLT),U,2) Q "-1"_U_$G(ORRSLT)
;get and parse the response HL7
S ORFS=$G(HL("FS")),ORCS=$E($G(HL("ECH")),1),ORRS=$E($G(HL("ECH")),2),ORES=$E($G(HL("ECH")),3),ORSS=$E($G(HL("ECH")),4)
N ORQUIT S ORQUIT=""
F X HLNEXT Q:HLQUIT'>0!(ORQUIT'="") D
.I $E(HLNODE,1,3)="MSA"&($P(HLNODE,ORFS,2)'="AA") S ORQUIT=$P(HLNODE,ORFS,2)
.I $E(HLNODE,1,3)="ERR" S ORQUIT=$P(HLNODE,ORFS,2)
.I $E(HLNODE,1,3)="RDT"&($P(HLNODE,ORFS,2)="S") D
..S ^XTMP("ORRDI",0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
..I DOMAIN="ART" D ALPARSE(DFN,.HLNODE)
..I DOMAIN="PSOO" D PSPARSE(DFN,.HLNODE)
I $L(ORQUIT) Q "-2"_U_ORQUIT
S RET=$O(^XTMP("ORRDI",DOMAIN,DFN,""),-1)
Q $G(RET)
ALPARSE(DFN,DATA) ;parse an individual ART record that comes from CDS
I '$D(DATA(0)) S DATA(0)=DATA
N Y,I,SEQ,TMPREACT,I,DCCOUNT,DICOUNT
S SEQ=$O(^XTMP("ORRDI","ART",DFN,""),-1)+1
D PIECEOUT^ORRDI2(.Y,.DATA,ORFS)
Q:Y(4)="EE"
;Q:$$UP^XLFSTR($P(Y(5),ORCS,2))'["DRUG"
;save the originating facility
S ^XTMP("ORRDI","ART",DFN,SEQ,"FACILITY",0)=Y(3)
;save reactant to the XTMP if it is coded
S TMPREACT=$TR(Y(6),ORCS,ORFS)
N CODING S CODING=$P(TMPREACT,ORFS,6)
S:$E(CODING,1,4)="99VA" ^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",0)=$P(TMPREACT,ORFS,4,6)
;save drug classes to the XTMP (only coded values)
S I=0,DCCOUNT=0 F I=1:1:$L(Y(9),ORRS) D
. N TMP
. S TMP=$TR($P(Y(9),ORRS,I),ORCS,ORFS)
. ;check if drug class is coded
. N CODING S CODING=$P(TMP,ORFS,3) Q:$E(CODING,1,9)'="99VHA_ERT"
. S DCCOUNT=DCCOUNT+1
. S $P(TMP,ORFS,6)="99VA"_$P($P(TMP,ORFS,6),"_",2)
. S ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",DCCOUNT)=$P(TMP,ORFS,4)_U_$P(TMP,ORFS,4)_U_$P(TMP,ORFS,6)_U_$P(TMP,ORFS,5)
;save drug ingredients to the XTMP (only coded values)
S I=0,DICOUNT=0 F I=1:1:$L(Y(10),ORRS) D
. N TMP
. S TMP=$TR($P(Y(10),ORRS,I),ORCS,ORFS)
. ;check if drug ingredient is coded
. N CODING S CODING=$P(TMP,ORFS,6) Q:$E(CODING,1,4)'="99VA"
. S DICOUNT=DICOUNT+1
. S ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",DICOUNT)=$P(TMP,ORFS,4,6)
S I="" F S I=$O(^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I)) Q:I="" S ^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I))
S I="" F S I=$O(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I)) Q:I="" S ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I))
S I="" F S I=$O(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I)) Q:I="" S ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I))
Q
PSPARSE(DFN,DATA) ;parse an individual PSOO record from CDS
I '$D(DATA(0)) S DATA(0)=DATA
N Y,I,COUNT,MAP,PIECE,SEQ
D PIECEOUT^ORRDI2(.Y,.DATA,ORFS)
S SEQ=$O(^XTMP("ORRDI","PSOO",DFN,""),-1)+1
S I="",COUNT=0,MAP="1,2,4,5,6,7,8,9,10,11,12,14"
F I=18,4,6,7,8,10,11,12,13,14,15,16 S PIECE(I)=Y(I),COUNT=COUNT+1,^XTMP("ORRDI","PSOO",DFN,SEQ,$P(MAP,",",COUNT),0)=PIECE(I)
S ^XTMP("ORRDI","PSOO",DFN,SEQ,1,0)=$P(^XTMP("ORRDI","PSOO",DFN,SEQ,1,0),ORCS,1)
I '$L(^XTMP("ORRDI","PSOO",DFN,SEQ,1,0))!(Y(17)=200) S ^XTMP("ORRDI","PSOO",DFN,SEQ,1,0)=Y(3)
S ^XTMP("ORRDI","PSOO",DFN,SEQ,6,0)=^XTMP("ORRDI","PSOO",DFN,SEQ,6,0)_";"_Y(9)
S ^XTMP("ORRDI","PSOO",DFN,SEQ,5,0)=$P(^XTMP("ORRDI","PSOO",DFN,SEQ,5,0),ORCS,5)
S ^XTMP("ORRDI","PSOO",DFN,SEQ,3,0)=$P($P(^XTMP("ORRDI","PSOO",DFN,SEQ,2,0),ORCS,4),".")
S ^XTMP("ORRDI","PSOO",DFN,SEQ,2,0)=$P(^XTMP("ORRDI","PSOO",DFN,SEQ,2,0),ORCS,5)
S ^XTMP("ORRDI","PSOO",DFN,SEQ,7,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,7,0))
S ^XTMP("ORRDI","PSOO",DFN,SEQ,8,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,8,0))
S ^XTMP("ORRDI","PSOO",DFN,SEQ,9,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,9,0))
S I="" F S I=$O(^XTMP("ORRDI","PSOO",DFN,SEQ,I)) Q:I="" S ^XTMP("ORRDI","PSOO",DFN,SEQ,I,0)=$$REMESC($G(^XTMP("ORRDI","PSOO",DFN,SEQ,I,0)))
Q
DTCONV(DATE) ;convert date in hl7 format to mm/dd/yy
Q $E(DATE,5,6)_"/"_$E(DATE,7,8)_"/"_$E(DATE,3,4)
;Q $E(DATE,1,6)_$E($P(DATE,"/",3),3,4)
REMESC(ORSTR) ;
; Remove Escape Characters from HL7 Message Text
; Escape Sequence codes:
; F = field separator (ORFS)
; S = component separator (ORCS)
; R = repetition separator (ORRS)
; E = escape character (ORES)
; T = subcomponent separator (ORSS)
N ORCHR,ORREP,I1,I2,J1,J2,K,VALUE
F ORCHR="F","S","R","E","T" S ORREP(ORES_ORCHR_ORES)=$S(ORCHR="F":ORFS,ORCHR="S":ORCS,ORCHR="R":ORRS,ORCHR="E":ORES,ORCHR="T":ORSS)
S ORSTR=$$REPLACE^XLFSTR(ORSTR,.ORREP)
F S I1=$P(ORSTR,ORES_"X") Q:$L(I1)=$L(ORSTR) D
.S I2=$P(ORSTR,ORES_"X",2,99)
.S J1=$P(I2,ORES) Q:'$L(J1)
.S J2=$P(I2,ORES,2,99)
.S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
.S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE))
.S ORSTR=I1_K_J2
Q ORSTR
ORRDI1 ;SLC/JMH - RDI routines for API supporting CDS data; 3/24/05 2:31 [8/11/05 6:25am] ; 1/11/07 8:33am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**232**;Dec 17, 1997;Build 19
+2 ;
GET(DFN,DOMAIN) ;API for packages to call in order to get data from HDR for
+1 ; check if in OUTAGE state and quit if so
+2 IF $$DOWNXVAL^ORRDI2
Begin DoDot:1
+3 KILL ^XTMP("ORRDI",DOMAIN,DFN)
+4 SET ^XTMP("ORRDI",DOMAIN,DFN,0)="^^-1"
End DoDot:1
QUIT -1
+5 ; order checking purposes
+6 NEW I,ORCACHE,ORRET,ORRECDT
+7 ;check if data was just retrieved a short time ago and if so return
+8 SET ORRECDT=$PIECE($GET(^XTMP("ORRDI",DOMAIN,DFN,0)),U)
+9 SET ORCACHE=$$GET^XPAR("SYS","OR RDI CACHE TIME")
+10 IF $$FMDIFF^XLFDT($$NOW^XLFDT,ORRECDT,2)<(60*ORCACHE)
IF $PIECE(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)>-1
SET ORRET=$PIECE(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)
+11 ;check if there has been an HDR down condition within last minute
+12 IF $$FMDIFF^XLFDT($$NOW^XLFDT,$PIECE($GET(^XTMP("ORRDI","PSOO",DFN,0)),U),2)<60
IF $PIECE($GET(^XTMP("ORRDI","PSOO",DFN,0)),U,3)<0
SET ORRET=$PIECE($GET(^XTMP("ORRDI","PSOO",DFN,0)),U,3)
+13 IF $$FMDIFF^XLFDT($$NOW^XLFDT,$PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),U),2)<60
IF $PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),U,3)<0
SET ORRET=$PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),U,3)
+14 ;if data is not "fresh" then go get it
+15 IF '$LENGTH($GET(ORRET))
Begin DoDot:1
+16 SET ORRET=$$RETRIEVE(DFN,DOMAIN)
+17 IF ORRET>-1
SET ^XTMP("ORRDI","OUTAGE INFO","FAILURES")=0
+18 IF ORRET'>-1
Begin DoDot:2
+19 IF $PIECE(ORRET,U,2)="PATIENT ICN NOT FOUND"
QUIT
+20 SET ^XTMP("ORRDI","OUTAGE INFO","FAILURES")=$$FAILXVAL^ORRDI2+1
+21 IF $$FAILXVAL^ORRDI2'<$$FAILPVAL^ORRDI2
Begin DoDot:3
+22 SET ^XTMP("ORRDI","OUTAGE INFO","DOWN")=1
+23 DO SPAWN^ORRDI2
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET $PIECE(^XTMP("ORRDI",DOMAIN,DFN,0),U,3)=ORRET
+25 IF ORRET<1
Begin DoDot:1
+26 NEW TEMP
SET TEMP=^XTMP("ORRDI",DOMAIN,DFN,0)
+27 KILL ^XTMP("ORRDI",DOMAIN,DFN)
+28 SET ^XTMP("ORRDI",DOMAIN,DFN,0)=TEMP
End DoDot:1
+29 QUIT ORRET
HAVEHDR() ;call to check if this system has an HDR to perform order checks
+1 ; against
+2 ;check parameter to see if there is an HDR and returns positive if so
+3 IF $$GET^XPAR("SYS","OR RDI HAVE HDR")
QUIT 1
+4 ;returns negative because the parameter indicates there is no HDR
+5 QUIT 0
RETRIEVE(DFN,DOMAIN) ;actually go get the data from CDS
+1 KILL ^XTMP("ORRDI",DOMAIN,DFN)
+2 NEW START,END,HLL,HLA,ORFS,ORCS,ORRS,ORES,ORSS
+3 NEW Y,ORRSLT,ICN,WHATOUT,HLNEXT,HLNODE,HLQUIT,ORHLP,RET,HL,HLDOM,HLDONE1,HLECH,HLFS,HLINSTN,HLMTIEN,HLPARAM,HLQ,STATUS,PRE
+4 SET (ORFS,ORCS,ORRS,ORES,ORSS)=""
+5 ;S START=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),-120),END=$$FMADD^XLFDT($P($$NOW^XLFDT,"."),485)
+6 ;set up what codes for specific domains
+7 IF DOMAIN="ART"
SET WHATOUT="039OC_AL:ALLERGIES"
+8 IF DOMAIN="PSOO"
SET WHATOUT="055OC_RXOP:PHARMACY ALL OUTPATIENT"
SET START=$$FMADD^XLFDT($PIECE($$NOW^XLFDT,"."),-30)
+9 ;get patient identifier (ICN)
+10 DO SELECT^ORWPT(.Y,DFN)
+11 SET ICN=$PIECE($GET(Y),U,14)
+12 IF 'ICN
QUIT -1_"^PATIENT ICN NOT FOUND"
+13 ;build HLA array with request HL7
+14 SET HLA("HLS",1)="SPR^XWBDRPC845-569716_0^T^ZREMOTE RPC^@SPR.4.2~003RPC017ORWRP REPORT TEXT&006RPCVER0010&007XWBPCNT0017&007XWBESSO066321214321\F\\F\\F\657\F"
+15 SET HLA("HLS",1,1)="\48102&007XWBDVER0011&006XWBSEC0043.14&002P10187369543;"_ICN_"&002P2"_WHATOUT_";1\S\RXOP;ORDV06;28;200&002P3000&002P4000&002P5000&002P600"_$LENGTH($GET(START))_$GET(START)_"&002P700"_$LENGTH($GET(END))_$GET(END)
+16 SET HLA("HLS",2)="RDF^1^@DSP.3~TX~300"
+17 ;set HLL("LINKS") node to specify receiver location
+18 SET HLL("LINKS",1)="ORRDI SUBSCRIBER^ORHDR"
+19 SET ORHLP("OPEN TIMEOUT")=10
+20 SET ORHLP("SUBSCRIBER")="^OR RDI SENDER^"_$PIECE($$SITE^VASITE,U,3)_"^OR RDI RECEIVER^^^"
+21 ;call DIRECT^HLMA to send request
+22 DO DIRECT^HLMA("ORRDI EVENT","LM",1,.ORRSLT,,.ORHLP)
+23 ;set time stamp of the data
+24 IF $GET(ORRSLT)
SET ^XTMP("ORRDI",DOMAIN,DFN,0)=$$NOW^XLFDT
+25 ;check if call failed
+26 IF $PIECE($GET(ORRSLT),U,2)
QUIT "-1"_U_$GET(ORRSLT)
+27 ;get and parse the response HL7
+28 SET ORFS=$GET(HL("FS"))
SET ORCS=$EXTRACT($GET(HL("ECH")),1)
SET ORRS=$EXTRACT($GET(HL("ECH")),2)
SET ORES=$EXTRACT($GET(HL("ECH")),3)
SET ORSS=$EXTRACT($GET(HL("ECH")),4)
+29 NEW ORQUIT
SET ORQUIT=""
+30 FOR
XECUTE HLNEXT
IF HLQUIT'>0!(ORQUIT'="")
QUIT
Begin DoDot:1
+31 IF $EXTRACT(HLNODE,1,3)="MSA"&($PIECE(HLNODE,ORFS,2)'="AA")
SET ORQUIT=$PIECE(HLNODE,ORFS,2)
+32 IF $EXTRACT(HLNODE,1,3)="ERR"
SET ORQUIT=$PIECE(HLNODE,ORFS,2)
+33 IF $EXTRACT(HLNODE,1,3)="RDT"&($PIECE(HLNODE,ORFS,2)="S")
Begin DoDot:2
+34 SET ^XTMP("ORRDI",0)=$$FMADD^XLFDT($$NOW^XLFDT,2)_U_$$NOW^XLFDT
+35 IF DOMAIN="ART"
DO ALPARSE(DFN,.HLNODE)
+36 IF DOMAIN="PSOO"
DO PSPARSE(DFN,.HLNODE)
End DoDot:2
End DoDot:1
+37 IF $LENGTH(ORQUIT)
QUIT "-2"_U_ORQUIT
+38 SET RET=$ORDER(^XTMP("ORRDI",DOMAIN,DFN,""),-1)
+39 QUIT $GET(RET)
ALPARSE(DFN,DATA) ;parse an individual ART record that comes from CDS
+1 IF '$DATA(DATA(0))
SET DATA(0)=DATA
+2 NEW Y,I,SEQ,TMPREACT,I,DCCOUNT,DICOUNT
+3 SET SEQ=$ORDER(^XTMP("ORRDI","ART",DFN,""),-1)+1
+4 DO PIECEOUT^ORRDI2(.Y,.DATA,ORFS)
+5 IF Y(4)="EE"
QUIT
+6 ;Q:$$UP^XLFSTR($P(Y(5),ORCS,2))'["DRUG"
+7 ;save the originating facility
+8 SET ^XTMP("ORRDI","ART",DFN,SEQ,"FACILITY",0)=Y(3)
+9 ;save reactant to the XTMP if it is coded
+10 SET TMPREACT=$TRANSLATE(Y(6),ORCS,ORFS)
+11 NEW CODING
SET CODING=$PIECE(TMPREACT,ORFS,6)
+12 IF $EXTRACT(CODING,1,4)="99VA"
SET ^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",0)=$PIECE(TMPREACT,ORFS,4,6)
+13 ;save drug classes to the XTMP (only coded values)
+14 SET I=0
SET DCCOUNT=0
FOR I=1:1:$LENGTH(Y(9),ORRS)
Begin DoDot:1
+15 NEW TMP
+16 SET TMP=$TRANSLATE($PIECE(Y(9),ORRS,I),ORCS,ORFS)
+17 ;check if drug class is coded
+18 NEW CODING
SET CODING=$PIECE(TMP,ORFS,3)
IF $EXTRACT(CODING,1,9)'="99VHA_ERT"
QUIT
+19 SET DCCOUNT=DCCOUNT+1
+20 SET $PIECE(TMP,ORFS,6)="99VA"_$PIECE($PIECE(TMP,ORFS,6),"_",2)
+21 SET ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",DCCOUNT)=$PIECE(TMP,ORFS,4)_U_$PIECE(TMP,ORFS,4)_U_$PIECE(TMP,ORFS,6)_U_$PIECE(TMP,ORFS,5)
End DoDot:1
+22 ;save drug ingredients to the XTMP (only coded values)
+23 SET I=0
SET DICOUNT=0
FOR I=1:1:$LENGTH(Y(10),ORRS)
Begin DoDot:1
+24 NEW TMP
+25 SET TMP=$TRANSLATE($PIECE(Y(10),ORRS,I),ORCS,ORFS)
+26 ;check if drug ingredient is coded
+27 NEW CODING
SET CODING=$PIECE(TMP,ORFS,6)
IF $EXTRACT(CODING,1,4)'="99VA"
QUIT
+28 SET DICOUNT=DICOUNT+1
+29 SET ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",DICOUNT)=$PIECE(TMP,ORFS,4,6)
End DoDot:1
+30 SET I=""
FOR
SET I=$ORDER(^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I))
IF I=""
QUIT
SET ^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"REACTANT",I))
+31 SET I=""
FOR
SET I=$ORDER(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I))
IF I=""
QUIT
SET ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG INGREDIENTS",I))
+32 SET I=""
FOR
SET I=$ORDER(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I))
IF I=""
QUIT
SET ^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I)=$$REMESC(^XTMP("ORRDI","ART",DFN,SEQ,"DRUG CLASSES",I))
+33 QUIT
PSPARSE(DFN,DATA) ;parse an individual PSOO record from CDS
+1 IF '$DATA(DATA(0))
SET DATA(0)=DATA
+2 NEW Y,I,COUNT,MAP,PIECE,SEQ
+3 DO PIECEOUT^ORRDI2(.Y,.DATA,ORFS)
+4 SET SEQ=$ORDER(^XTMP("ORRDI","PSOO",DFN,""),-1)+1
+5 SET I=""
SET COUNT=0
SET MAP="1,2,4,5,6,7,8,9,10,11,12,14"
+6 FOR I=18,4,6,7,8,10,11,12,13,14,15,16
SET PIECE(I)=Y(I)
SET COUNT=COUNT+1
SET ^XTMP("ORRDI","PSOO",DFN,SEQ,$PIECE(MAP,",",COUNT),0)=PIECE(I)
+7 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,1,0)=$PIECE(^XTMP("ORRDI","PSOO",DFN,SEQ,1,0),ORCS,1)
+8 IF '$LENGTH(^XTMP("ORRDI","PSOO",DFN,SEQ,1,0))!(Y(17)=200)
SET ^XTMP("ORRDI","PSOO",DFN,SEQ,1,0)=Y(3)
+9 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,6,0)=^XTMP("ORRDI","PSOO",DFN,SEQ,6,0)_";"_Y(9)
+10 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,5,0)=$PIECE(^XTMP("ORRDI","PSOO",DFN,SEQ,5,0),ORCS,5)
+11 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,3,0)=$PIECE($PIECE(^XTMP("ORRDI","PSOO",DFN,SEQ,2,0),ORCS,4),".")
+12 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,2,0)=$PIECE(^XTMP("ORRDI","PSOO",DFN,SEQ,2,0),ORCS,5)
+13 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,7,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,7,0))
+14 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,8,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,8,0))
+15 SET ^XTMP("ORRDI","PSOO",DFN,SEQ,9,0)=$$DTCONV(^XTMP("ORRDI","PSOO",DFN,SEQ,9,0))
+16 SET I=""
FOR
SET I=$ORDER(^XTMP("ORRDI","PSOO",DFN,SEQ,I))
IF I=""
QUIT
SET ^XTMP("ORRDI","PSOO",DFN,SEQ,I,0)=$$REMESC($GET(^XTMP("ORRDI","PSOO",DFN,SEQ,I,0)))
+17 QUIT
DTCONV(DATE) ;convert date in hl7 format to mm/dd/yy
+1 QUIT $EXTRACT(DATE,5,6)_"/"_$EXTRACT(DATE,7,8)_"/"_$EXTRACT(DATE,3,4)
+2 ;Q $E(DATE,1,6)_$E($P(DATE,"/",3),3,4)
REMESC(ORSTR) ;
+1 ; Remove Escape Characters from HL7 Message Text
+2 ; Escape Sequence codes:
+3 ; F = field separator (ORFS)
+4 ; S = component separator (ORCS)
+5 ; R = repetition separator (ORRS)
+6 ; E = escape character (ORES)
+7 ; T = subcomponent separator (ORSS)
+8 NEW ORCHR,ORREP,I1,I2,J1,J2,K,VALUE
+9 FOR ORCHR="F","S","R","E","T"
SET ORREP(ORES_ORCHR_ORES)=$SELECT(ORCHR="F":ORFS,ORCHR="S":ORCS,ORCHR="R":ORRS,ORCHR="E":ORES,ORCHR="T":ORSS)
+10 SET ORSTR=$$REPLACE^XLFSTR(ORSTR,.ORREP)
+11 FOR
SET I1=$PIECE(ORSTR,ORES_"X")
IF $LENGTH(I1)=$LENGTH(ORSTR)
QUIT
Begin DoDot:1
+12 SET I2=$PIECE(ORSTR,ORES_"X",2,99)
+13 SET J1=$PIECE(I2,ORES)
IF '$LENGTH(J1)
QUIT
+14 SET J2=$PIECE(I2,ORES,2,99)
+15 SET VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
+16 SET K=$SELECT(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$CHAR(VALUE))
+17 SET ORSTR=I1_K_J2
End DoDot:1
+18 QUIT ORSTR
