RORHL14 ;HOIFO/BH,SG - HL7 ALLERGY DATA: OBR,OBX ; 8/26/05 2:43pm
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
; This routine uses the following IAs:
;
; #2167 Read access to the file #120.83 (controlled)
; #4531 ZERO^PSN50P41
; #4543 IEN^PSN50P65
; #10060 Read access to the file #200 (supported)
;
;
Q
;
;***** SEARCHES FOR ALLERGY DATA
;
; RORDFN IEN of the patient in the PATIENT file (#2)
;
; .DXDTS Reference to a local variable where the
; data extraction time frames are stored.
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
EN1(RORDFN,DXDTS) ;
N ERRCNT,IDX,RC,RORARR,RORDTE,RORENDT,RORIEN,RORSTDT,TMP
S (ERRCNT,RC)=0
;
S IDX=0
F S IDX=$O(DXDTS(13,IDX)) Q:IDX'>0 D Q:RC<0
. S RORSTDT=$P(DXDTS(13,IDX),U),RORENDT=$P(DXDTS(13,IDX),U,2)
. ;---
. S RORDTE=$O(^GMR(120.8,"AODT",RORSTDT),-1)
. F S RORDTE=$O(^GMR(120.8,"AODT",RORDTE)) Q:'RORDTE!(RORDTE'<RORENDT) D
. . S RORIEN=0
. . F S RORIEN=$O(^GMR(120.8,"AODT",RORDTE,RORIEN)) Q:'RORIEN D
. . . S:$D(^GMR(120.8,"B",RORDFN,RORIEN)) RORARR(RORIEN)=""
. I $D(RORARR)<10 S ERRCNT=ERRCNT+1 Q
. ;
. S RORIEN=0
. F S RORIEN=$O(RORARR(RORIEN)) Q:'RORIEN D
. . S TMP=$$OBR(RORIEN,RORDFN)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . S TMP=$$OBX(RORIEN,RORDFN)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
;
Q $S(RC<0:RC,1:ERRCNT)
;
;***** ALLERGY OBR SEGMENT BUILDER
;
; RORAIEN IEN of Allergy entry
; RORDFN IEN of the patient in the PATIENT file (#2)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBR(RORAIEN,RORDFN) ;
N BUF,CS,ERRCNT,RC,RORLST,RORMSG,RORSEG,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
;
S RORAIEN=RORAIEN_","
D GETS^DIQ(120.8,RORAIEN,".02;3.1;4;5;6","EI","RORLST","RORMSG")
I $G(DIERR) D S ERRCNT=ERRCNT+1
. D DBS^RORERR("RORMSG",-9,,RORDFN,120.8,RORAIEN)
;
;--- Initialize the segment
S RORSEG(0)="OBR"
;
;--- OBR-3 - IEN of the record
S RORSEG(3)=$P(RORAIEN,",")
;
;--- OBR-4 - Sevice ID
S RORSEG(4)="95000"_CS_"ALLERGY"_CS_"C4"
;
;--- OBR-7 - Observation Date/Time (Origination Date)
S TMP=$$FMTHL7^XLFDT($G(RORLST(120.8,RORAIEN,4,"I")))
Q:TMP'>0 $$ERROR^RORERR(-95,,,RORDFN,120.8,RORAIEN,4)
S RORSEG(7)=TMP
;
;--- OBR-13 - Relevant Clinical Info. (Reactant)
S RORSEG(13)=$G(RORLST(120.8,RORAIEN,.02,"E"))
;
;--- OBR-16 - Ordering Provider
S BUF=$G(RORLST(120.8,RORAIEN,5,"I"))
I BUF>0 D
. S $P(BUF,CS,13)=$$GET1^DIQ(200,+BUF_",",53.5,"E",,"RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
. . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+BUF_",")
. S RORSEG(16)=BUF
;
;--- OBR-20 - Filler Field 1 (Allergy Type)
S RORSEG(20)=$G(RORLST(120.8,RORAIEN,3.1,"E"))
;
;--- OBR-24 - Diagnostic Service ID
S RORSEG(24)="TX"
;
;--- OBR-25 - Result Status (Observed/Historical)
S TMP=$G(RORLST(120.8,RORAIEN,6,"E"))
I TMP'="" D S RORSEG(25)=TMP
. S TMP=$S(TMP="HISTORICAL":"R",TMP="OBSERVED":"F",1:"")
;
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q ERRCNT
;
;***** ALLERGY OBX SEGMENT(S) BUILDER
;
; RORAIEN IEN of Allergy entry
; RORDFN IEN of the patient in the PATIENT file (#2)
;
; Return Values:
; <0 Error code
; 0 Ok
; >0 Non-fatal error(s)
;
OBX(RORAIEN,RORDFN) ;
N BUF,CS,DTE,ERRCNT,IEN,RC,REAC,RORID,RORIENS,RORKEY,RORLST,RORMSG,RORSEG,RORTMP,RORTS,RPS,TMP
S (ERRCNT,RC)=0,RORIENS=","_RORAIEN_","
D ECH^RORHL7(.CS,,.RPS)
;
;=== Ingredients
K RORLST,RORMSG
D LIST^DIC(120.802,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
I $G(DIERR) D Q RC
. S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.802,RORIENS)
S RORID="INGR"_CS_"Ingredients"_CS_"VA080"
;---
S RORTMP=$$ALLOC^RORTMP(.RORTS)
S RORKEY=0
F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
. S IEN=+$G(RORLST("DILIST","ID",RORKEY,.01)) Q:IEN'>0
. D ZERO^PSN50P41(IEN,,,RORTS)
. S TMP=$G(@RORTMP@(IEN,.01))
. D:TMP'="" SETOBX(TMP,RORID)
D FREE^RORTMP(RORTMP)
;
;=== Classes
K RORLST,RORMSG
D LIST^DIC(120.803,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
I $G(DIERR) D Q RC
. S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.803,RORIENS)
;---
S RORTMP=$$ALLOC^RORTMP(.RORTS)
S (CNT,RORKEY)=0,BUF=""
F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
. S IEN=+$G(RORLST("DILIST","ID",RORKEY,.01)) Q:IEN'>0
. D IEN^PSN50P65(IEN,,RORTS)
. S TMP=$G(@RORTMP@(IEN,.01))
. S:TMP'="" BUF=BUF_$S(BUF'="":RPS_TMP,1:TMP)
D:BUF'="" SETOBX(BUF,"CLAS"_CS_"Drug Class"_CS_"VA080")
D FREE^RORTMP(RORTMP)
;
;=== Reactions
K RORLST,RORMSG
D LIST^DIC(120.81,RORIENS,"@;.01;3","I",,,,,,,"RORLST","RORMSG")
I $G(DIERR) D Q RC
. S RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.81,RORIENS)
S RORID="RCTS"_CS_"Reactions"_CS_"VA080"
;---
S RORKEY=0
F S RORKEY=$O(RORLST("DILIST","ID",RORKEY)) Q:'RORKEY D
. S IEN=RORLST("DILIST","ID",RORKEY,.01) Q:IEN'>0
. S REAC=$$GET1^DIQ(120.83,IEN_",",.01,"E",,"RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
. . D DBS^RORERR("RORMSG",-99,,RORDFN,120.83,IEN_",")
. Q:REAC=""
. S DTE=$$FM2HL^RORHL7($G(RORLST("DILIST","ID",RORKEY,3)))
. D SETOBX(REAC,RORID,DTE)
;
Q $S(RC<0:RC,1:ERRCNT)
;
;***** CREATES AND STORES THE OBX SEGMENT
SETOBX(OBX5,OBX3,OBX12) ;
N RORSEG
;--- Initialize the segment
S RORSEG(0)="OBX"
;--- OBX-2 - Value Type
S RORSEG(2)="FT"
;--- OBX-3 - Observation Identifier
S RORSEG(3)=OBX3
;--- OBX-5 - Observation Value
S RORSEG(5)=OBX5
;--- OBX-11 - Observation Result Status
S RORSEG(11)="F"
;--- OBX-12 - Reactions Date/Time Entered
S:$G(OBX12)'="" RORSEG(12)=OBX12
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHL14 5865 printed Apr 09, 2024@20:49:25 Page 2
RORHL14 ;HOIFO/BH,SG - HL7 ALLERGY DATA: OBR,OBX ; 8/26/05 2:43pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2167 Read access to the file #120.83 (controlled)
+6 ; #4531 ZERO^PSN50P41
+7 ; #4543 IEN^PSN50P65
+8 ; #10060 Read access to the file #200 (supported)
+9 ;
+10 ;
+11 QUIT
+12 ;
+13 ;***** SEARCHES FOR ALLERGY DATA
+14 ;
+15 ; RORDFN IEN of the patient in the PATIENT file (#2)
+16 ;
+17 ; .DXDTS Reference to a local variable where the
+18 ; data extraction time frames are stored.
+19 ;
+20 ; Return Values:
+21 ; <0 Error code
+22 ; 0 Ok
+23 ; >0 Non-fatal error(s)
+24 ;
EN1(RORDFN,DXDTS) ;
+1 NEW ERRCNT,IDX,RC,RORARR,RORDTE,RORENDT,RORIEN,RORSTDT,TMP
+2 SET (ERRCNT,RC)=0
+3 ;
+4 SET IDX=0
+5 FOR
SET IDX=$ORDER(DXDTS(13,IDX))
if IDX'>0
QUIT
Begin DoDot:1
+6 SET RORSTDT=$PIECE(DXDTS(13,IDX),U)
SET RORENDT=$PIECE(DXDTS(13,IDX),U,2)
+7 ;---
+8 SET RORDTE=$ORDER(^GMR(120.8,"AODT",RORSTDT),-1)
+9 FOR
SET RORDTE=$ORDER(^GMR(120.8,"AODT",RORDTE))
if 'RORDTE!(RORDTE'<RORENDT)
QUIT
Begin DoDot:2
+10 SET RORIEN=0
+11 FOR
SET RORIEN=$ORDER(^GMR(120.8,"AODT",RORDTE,RORIEN))
if 'RORIEN
QUIT
Begin DoDot:3
+12 if $DATA(^GMR(120.8,"B",RORDFN,RORIEN))
SET RORARR(RORIEN)=""
End DoDot:3
End DoDot:2
+13 IF $DATA(RORARR)<10
SET ERRCNT=ERRCNT+1
QUIT
+14 ;
+15 SET RORIEN=0
+16 FOR
SET RORIEN=$ORDER(RORARR(RORIEN))
if 'RORIEN
QUIT
Begin DoDot:2
+17 SET TMP=$$OBR(RORIEN,RORDFN)
+18 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+19 SET TMP=$$OBX(RORIEN,RORDFN)
+20 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
End DoDot:2
End DoDot:1
if RC<0
QUIT
+21 ;
+22 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+23 ;
+24 ;***** ALLERGY OBR SEGMENT BUILDER
+25 ;
+26 ; RORAIEN IEN of Allergy entry
+27 ; RORDFN IEN of the patient in the PATIENT file (#2)
+28 ;
+29 ; Return Values:
+30 ; <0 Error code
+31 ; 0 Ok
+32 ; >0 Non-fatal error(s)
+33 ;
OBR(RORAIEN,RORDFN) ;
+1 NEW BUF,CS,ERRCNT,RC,RORLST,RORMSG,RORSEG,TMP
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 ;
+5 SET RORAIEN=RORAIEN_","
+6 DO GETS^DIQ(120.8,RORAIEN,".02;3.1;4;5;6","EI","RORLST","RORMSG")
+7 IF $GET(DIERR)
Begin DoDot:1
+8 DO DBS^RORERR("RORMSG",-9,,RORDFN,120.8,RORAIEN)
End DoDot:1
SET ERRCNT=ERRCNT+1
+9 ;
+10 ;--- Initialize the segment
+11 SET RORSEG(0)="OBR"
+12 ;
+13 ;--- OBR-3 - IEN of the record
+14 SET RORSEG(3)=$PIECE(RORAIEN,",")
+15 ;
+16 ;--- OBR-4 - Sevice ID
+17 SET RORSEG(4)="95000"_CS_"ALLERGY"_CS_"C4"
+18 ;
+19 ;--- OBR-7 - Observation Date/Time (Origination Date)
+20 SET TMP=$$FMTHL7^XLFDT($GET(RORLST(120.8,RORAIEN,4,"I")))
+21 if TMP'>0
QUIT $$ERROR^RORERR(-95,,,RORDFN,120.8,RORAIEN,4)
+22 SET RORSEG(7)=TMP
+23 ;
+24 ;--- OBR-13 - Relevant Clinical Info. (Reactant)
+25 SET RORSEG(13)=$GET(RORLST(120.8,RORAIEN,.02,"E"))
+26 ;
+27 ;--- OBR-16 - Ordering Provider
+28 SET BUF=$GET(RORLST(120.8,RORAIEN,5,"I"))
+29 IF BUF>0
Begin DoDot:1
+30 SET $PIECE(BUF,CS,13)=$$GET1^DIQ(200,+BUF_",",53.5,"E",,"RORMSG")
+31 IF $GET(DIERR)
Begin DoDot:2
+32 DO DBS^RORERR("RORMSG",-99,,RORDFN,200,+BUF_",")
End DoDot:2
SET ERRCNT=ERRCNT+1
QUIT
+33 SET RORSEG(16)=BUF
End DoDot:1
+34 ;
+35 ;--- OBR-20 - Filler Field 1 (Allergy Type)
+36 SET RORSEG(20)=$GET(RORLST(120.8,RORAIEN,3.1,"E"))
+37 ;
+38 ;--- OBR-24 - Diagnostic Service ID
+39 SET RORSEG(24)="TX"
+40 ;
+41 ;--- OBR-25 - Result Status (Observed/Historical)
+42 SET TMP=$GET(RORLST(120.8,RORAIEN,6,"E"))
+43 IF TMP'=""
Begin DoDot:1
+44 SET TMP=$SELECT(TMP="HISTORICAL":"R",TMP="OBSERVED":"F",1:"")
End DoDot:1
SET RORSEG(25)=TMP
+45 ;
+46 ;--- Store the segment
+47 DO ADDSEG^RORHL7(.RORSEG)
+48 QUIT ERRCNT
+49 ;
+50 ;***** ALLERGY OBX SEGMENT(S) BUILDER
+51 ;
+52 ; RORAIEN IEN of Allergy entry
+53 ; RORDFN IEN of the patient in the PATIENT file (#2)
+54 ;
+55 ; Return Values:
+56 ; <0 Error code
+57 ; 0 Ok
+58 ; >0 Non-fatal error(s)
+59 ;
OBX(RORAIEN,RORDFN) ;
+1 NEW BUF,CS,DTE,ERRCNT,IEN,RC,REAC,RORID,RORIENS,RORKEY,RORLST,RORMSG,RORSEG,RORTMP,RORTS,RPS,TMP
+2 SET (ERRCNT,RC)=0
SET RORIENS=","_RORAIEN_","
+3 DO ECH^RORHL7(.CS,,.RPS)
+4 ;
+5 ;=== Ingredients
+6 KILL RORLST,RORMSG
+7 DO LIST^DIC(120.802,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
+8 IF $GET(DIERR)
Begin DoDot:1
+9 SET RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.802,RORIENS)
End DoDot:1
QUIT RC
+10 SET RORID="INGR"_CS_"Ingredients"_CS_"VA080"
+11 ;---
+12 SET RORTMP=$$ALLOC^RORTMP(.RORTS)
+13 SET RORKEY=0
+14 FOR
SET RORKEY=$ORDER(RORLST("DILIST","ID",RORKEY))
if 'RORKEY
QUIT
Begin DoDot:1
+15 SET IEN=+$GET(RORLST("DILIST","ID",RORKEY,.01))
if IEN'>0
QUIT
+16 DO ZERO^PSN50P41(IEN,,,RORTS)
+17 SET TMP=$GET(@RORTMP@(IEN,.01))
+18 if TMP'=""
DO SETOBX(TMP,RORID)
End DoDot:1
+19 DO FREE^RORTMP(RORTMP)
+20 ;
+21 ;=== Classes
+22 KILL RORLST,RORMSG
+23 DO LIST^DIC(120.803,RORIENS,"@;.01","I",,,,,,,"RORLST","RORMSG")
+24 IF $GET(DIERR)
Begin DoDot:1
+25 SET RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.803,RORIENS)
End DoDot:1
QUIT RC
+26 ;---
+27 SET RORTMP=$$ALLOC^RORTMP(.RORTS)
+28 SET (CNT,RORKEY)=0
SET BUF=""
+29 FOR
SET RORKEY=$ORDER(RORLST("DILIST","ID",RORKEY))
if 'RORKEY
QUIT
Begin DoDot:1
+30 SET IEN=+$GET(RORLST("DILIST","ID",RORKEY,.01))
if IEN'>0
QUIT
+31 DO IEN^PSN50P65(IEN,,RORTS)
+32 SET TMP=$GET(@RORTMP@(IEN,.01))
+33 if TMP'=""
SET BUF=BUF_$SELECT(BUF'="":RPS_TMP,1:TMP)
End DoDot:1
+34 if BUF'=""
DO SETOBX(BUF,"CLAS"_CS_"Drug Class"_CS_"VA080")
+35 DO FREE^RORTMP(RORTMP)
+36 ;
+37 ;=== Reactions
+38 KILL RORLST,RORMSG
+39 DO LIST^DIC(120.81,RORIENS,"@;.01;3","I",,,,,,,"RORLST","RORMSG")
+40 IF $GET(DIERR)
Begin DoDot:1
+41 SET RC=$$DBS^RORERR("RORMSG",-9,,RORDFN,120.81,RORIENS)
End DoDot:1
QUIT RC
+42 SET RORID="RCTS"_CS_"Reactions"_CS_"VA080"
+43 ;---
+44 SET RORKEY=0
+45 FOR
SET RORKEY=$ORDER(RORLST("DILIST","ID",RORKEY))
if 'RORKEY
QUIT
Begin DoDot:1
+46 SET IEN=RORLST("DILIST","ID",RORKEY,.01)
if IEN'>0
QUIT
+47 SET REAC=$$GET1^DIQ(120.83,IEN_",",.01,"E",,"RORMSG")
+48 IF $GET(DIERR)
Begin DoDot:2
+49 DO DBS^RORERR("RORMSG",-99,,RORDFN,120.83,IEN_",")
End DoDot:2
SET ERRCNT=ERRCNT+1
QUIT
+50 if REAC=""
QUIT
+51 SET DTE=$$FM2HL^RORHL7($GET(RORLST("DILIST","ID",RORKEY,3)))
+52 DO SETOBX(REAC,RORID,DTE)
End DoDot:1
+53 ;
+54 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+55 ;
+56 ;***** CREATES AND STORES THE OBX SEGMENT
SETOBX(OBX5,OBX3,OBX12) ;
+1 NEW RORSEG
+2 ;--- Initialize the segment
+3 SET RORSEG(0)="OBX"
+4 ;--- OBX-2 - Value Type
+5 SET RORSEG(2)="FT"
+6 ;--- OBX-3 - Observation Identifier
+7 SET RORSEG(3)=OBX3
+8 ;--- OBX-5 - Observation Value
+9 SET RORSEG(5)=OBX5
+10 ;--- OBX-11 - Observation Result Status
+11 SET RORSEG(11)="F"
+12 ;--- OBX-12 - Reactions Date/Time Entered
+13 if $GET(OBX12)'=""
SET RORSEG(12)=OBX12
+14 ;--- Store the segment
+15 DO ADDSEG^RORHL7(.RORSEG)
+16 QUIT
