- GMRAIAL1 ;BPOIFO/JG - BUILD HL7 ORU^R01 MESSAGE FOR ALLERGIES - PART 1 ; 17 Mar 2006 11:07 AM
- ;;4.0;Adverse Reaction Tracking;**22,23,34**;Mar 29, 1996
- VALID ;;VDEF HL7 MESSAGE BUILDER
- ; Creates HL7 V2.4 ORU^R01 message for allergy updates & assessments
- ;
- ; This routine uses the following IAs:
- ; #4248 - VDEFEL calls (controlled)
- ; #3630 - VAFCQRY calls (controlled)
- ; #2196 - ^PS(50.416,IEN,0) (controlled)
- ; #2574 - $$CLASS2^PSNAPIS (supported)
- ; #4571 - ERR^VDEFREQ (controlled)
- ; #4631 - XTID calls (supported)
- ;
- ; This routine is called at tag EN as a Function by VDEFREQ1
- ;
- ; This routine calls GMRAIAL2 for a portion of message
- ;
- Q
- ;
- EN(EVIEN,KEY,VFLAG,OUT,MSHP) ; Entry point
- ;
- ; Inputs: EVIEN = IEN of VDEF Event in file 577
- ; KEY - IEN of file to create message from
- ; VFLAG - "V" for VistA HL7 destination (default)
- ; OUT - target array, passed by reference
- ; MSHP - Piece 4 contains message subtype
- ;
- ; Output: Two part string with parts separated by "^"
- ; Part 1: "LM" - output in local array passed in "OUT" parameter
- ; "GM" - output in ^TMP("HLS",$J)
- ; Part 2: No longer used
- ;
- N DFN,HLFS,HLCM,HLSC,HLRP,HLES,HLQ,ALRDATA,ADD,ALTYPE,XX ;34
- N DATA,VAL,I,S,X,Y,Z,X1,HL7RC,IEN,IEN1,OUTX,GMRAPID,ENTERR
- N SEPF,SEPC,SEPR,SEPE,SEPS,ARRAY,CMP,SEQ,GMRAHL,RSLTSTA
- N GMRAFILE,GMRAIENS,GMRAVUID
- ;
- ; Initialize stuff
- K ^TMP("HLS",$J) S S=0,ARRAY="OUT("_"""HLS"""_",S)",TARGET="LM^"
- M GMRAHL=VDEFHL
- ;
- ; Determine whether API was Allergy Update or Assessment
- S ALTYPE=$S($P(MSHP,"~",4)="ALGY":1,$P(MSHP,"~",4)="ADAS":2,1:1)
- ;
- ; Set up HL7 delimiters
- S HLCM=$E(GMRAHL("ECH")),HLRP=$E(GMRAHL("ECH"),2),HLSC=$E(GMRAHL("ECH"),4),HLES=$E(GMRAHL("ECH"),3)
- S HLFS=GMRAHL("FS"),HLQ=GMRAHL("Q"),HL7RC=HLES_HLFS_HLCM_HLRP_HLSC
- D SETDLMS^VDEFEL
- ;
- ; Get allergy data, patient ID, 'entered in error data'
- ; based on whether it's an allergy update or an assessment
- ; Allergy: ALTYPE=1, Assessment: ALTYPE=2
- D:ALTYPE=1 G EXIT:ZTSTOP=1
- . S ALRDATA=$G(^GMR(120.8,KEY,0))
- . I ALRDATA="" D ERR^VDEFREQ("No data in file GMR(120.8) for IEN "_KEY) S ZTSTOP=1 Q
- . S DFN=$P(ALRDATA,U),ENTERR=$G(^GMR(120.8,KEY,"ER"))
- . S RSLTSTA=$E("FW",1+ENTERR) ;34
- . I $G(^DPT(DFN,0))="" D ERR^VDEFREQ("No data in file DPT for DFN "_DFN) S ZTSTOP=1 Q
- D:ALTYPE=2 G EXIT:ZTSTOP=1
- . S ENTERR="",ALRDATA=$G(^GMR(120.86,KEY,0))
- . I $P(ALRDATA,U,2)="" S ENTERR=1
- . S DFN=$S(+ENTERR=1:KEY,1:$P(ALRDATA,U))
- . I $G(^DPT(DFN,0))="" D ERR^VDEFREQ("No data in file DPT for DFN "_DFN) S ZTSTOP=1 Q
- ;
- ; Build segments for message in OUT, $P # = HL7 field #
- ;
- ; PID - Use MPI PID builder
- PID K GMRAPID S OUTX="",S=1,SEQ=""
- D BLDPID^VAFCQRY(DFN,1,SEQ,.GMRAPID,.GMRAHL)
- F I=2:1 Q:$G(GMRAPID(I))="" S GMRAPID(1,I-1)=GMRAPID(I) K GMRAPID(I)
- M OUTX=GMRAPID(1) K GMRAPID D SAVE
- ;
- ; OBR
- OBR S S=S+1,OUTX="",$P(OUTX,HLFS)=1
- S $P(OUTX,HLFS,3)=KEY_HLCM_$P(SITEPARM,U,6)_$S(ALTYPE=1:"_120.8",ALTYPE=2:"_120.86")
- S $P(OUTX,HLFS,4)=$P("ALLERGY,ASSESSMENT",",",ALTYPE)_HLCM_HLCM_"L"
- ;
- ; Result Status
- S $P(OUTX,HLFS,25)=$E("FE",1+ENTERR) ;34
- ;
- ; Date/time reaction entered in system
- S $P(OUTX,HLFS,7)=$$TS^VDEFEL($P(ALRDATA,U,4))
- ;
- ; Originator for allergy
- S XX=$P(ALRDATA,U,$P("5^3",U,ALTYPE)) ;34
- I XX'="" D ;Block added in 34
- . S XX=$$XCN200^VDEFEL(XX),XX=$TR(XX,HLCM,HLSC)
- . F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II))
- . S $P(OUTX,HLFS,32)=XX
- G OBRX:ALTYPE=2
- ;
- ; Repeating field of various person roles
- ; Enterer, Verifier, Error User, ID Band Marker, Chart Marker
- ; and associated dates
- S (X,Y,Z)=""
- ENT S XX=$P(ALRDATA,U,5) G VER:XX="" ;34
- S XX=$$XCN200^VDEFEL(XX),XX=$TR(XX,HLCM,HLSC) ;34
- F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II)) ;34
- S VAL=XX,$P(VAL,HLSC,8)="E",Z=VAL ;34
- S $P(Z,HLCM,2)=$$TS^VDEFEL($P(ALRDATA,U,4)),X=Z
- VER G ERR:$P(ALRDATA,U,17)=""
- S XX=$$XCN200^VDEFEL($P(ALRDATA,U,18)),XX=$TR(XX,HLCM,HLSC) ;34
- F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II)) ;34
- S VAL=XX,$P(VAL,HLSC,8)="V",Z=VAL ;34
- S $P(Z,HLCM,2)=$$TS^VDEFEL($P(ALRDATA,U,17)),X=$G(X)_HLRP_Z
- ERR S XX=+ENTERR G IDBM:'XX ;34
- S XX=$$XCN200^VDEFEL($P(ENTERR,U,3)),XX=$TR(XX,HLCM,HLSC) ;34
- F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II)) ;34
- S VAL=XX,$P(VAL,HLSC,8)="EE",Z=VAL ;34
- S $P(Z,HLCM,2)=$$TS^VDEFEL($P(ENTERR,U,2)),X=$G(X)_HLRP_Z
- ;
- ; May be multiple entries for ID Band & Chart Marker persons
- IDBM G CHRT:'$D(^GMR(120.8,KEY,14))
- S IEN1=0 F S IEN1=$O(^GMR(120.8,KEY,14,IEN1)) Q:'+IEN1 D
- . S X1=$G(^GMR(120.8,KEY,14,IEN1,0)) ;34
- . S XX=$$XCN200^VDEFEL($P(X1,U,2)),XX=$TR(XX,HLCM,HLSC) ;34
- . F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II)) ;34
- . S VAL=XX S:VAL="" VAL=Y S $P(VAL,HLSC,8)="BM",Z=VAL ;34
- . S $P(Z,HLCM,2)=$$TS^VDEFEL($P(X1,U,1)),X=$G(X)_HLRP_Z
- CHRT G OBR1:'$D(^GMR(120.8,KEY,13))
- S IEN1=0 F S IEN1=$O(^GMR(120.8,KEY,13,IEN1)) Q:'+IEN1 D
- . S X1=$G(^GMR(120.8,KEY,13,IEN1,0)) ;34
- . S XX=$$XCN200^VDEFEL($P(X1,U,2)),XX=$TR(XX,HLCM,HLSC) ;34
- . F II=2:1:7 S $P(XX,SEPS,II)=$$HL7RC($P(XX,SEPS,II)) ;34
- . S VAL=XX S:VAL="" VAL=Y S $P(VAL,HLSC,8)="CM",Z=VAL ;34
- . S $P(Z,HLCM,2)=$$TS^VDEFEL($P(X1,U,1)),X=$G(X)_HLRP_Z
- OBR1 S $P(OUTX,HLFS,34)=X
- ;
- ; Observed/Historical Indicator
- S X=$P(ALRDATA,U,6),GMRAVUID=$$GETVUID(120.8,6,X)
- S VAL=$P(GMRAVUID,U)_HLCM_$S(X="o":"OBSERVED",X="h":"HISTORICAL",1:"")
- S VAL=VAL_HLCM_$P(GMRAVUID,U,2)
- S $P(OUTX,HLFS,47)=VAL
- OBRX S OUTX="OBR"_HLFS_OUTX D SAVE
- ;
- ; If the record is missing both the Reactant and the GMR Allergy
- ; trap it as an error.
- I ALTYPE'=2,$P(ALRDATA,U,2)="",$P(ALRDATA,U,3)="" D ERR^VDEFREQ("Record is missing Reactant and GMR Allergy") S ZTSTOP=1 Q
- ;
- ; OK to continue, call GMRAIAL2 for the rest of the message
- CALL D ENTRY^GMRAIAL2
- ;
- ; Done building segments
- EXIT Q TARGET
- ;
- ;
- ; Place current string into message array.
- ; Turn string into array if length >245.
- ; Move local array to global if needed.
- SAVE N I
- I $P(OUTX,HLFS)'="PID",$L(OUTX)>245 D
- . K ADD S ADD=$E(OUTX,1,245),OUTX=$E(OUTX,246,$L(OUTX))
- . F I=1:1 S ADD(I)=$E(OUTX,1,245),OUTX=$E(OUTX,246,$L(OUTX)) Q:OUTX=""
- . K OUTX M OUTX=ADD
- M @ARRAY=OUTX
- ;
- ; Move local array to global if it's getting big.
- I $P(TARGET,U)="LM",$S<16000 D
- . K ^TMP("HLS",$J) M ^TMP("HLS",$J)=OUT("HLS") K OUT("HLS")
- . S $P(TARGET,U)="GM",ARRAY="^TMP("_"""HLS"""_",$J,S)"
- K OUTX,ADD
- Q
- ;
- ; Replace any HL7 coding chars. in strings with HL7 escape sequence
- ; Input: X = data string
- HL7RC(X) N OCHR,RCHR,RCHRI,TYPE,I F TYPE="E","F","C","R","S" D
- . S RCHRI=$S(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
- . S OCHR=$E(HL7RC,RCHRI),RCHR=$E("EFSRT",RCHRI)
- . Q:'$F(X,OCHR)
- . F I=1:1 Q:$E(X,I)="" I $E(X,I)=OCHR S X=$E(X,1,I-1)_HLES_RCHR_HLES_$E(X,I+1,999),I=I+2
- Q X
- ;
- ; Get the VUID value and set up name of coding system
- GETVUID(GMRAFILE,GMRAFLD,GMRADATA,GMRAFLSW) ;
- ; Input parameters:
- ; GMRAFILE - VistA File #
- ; GMRAFLD - Field # in GMRAFILE
- ; GMRADATA - Reference value to look up VUID for
- ; GMRAFLSW - (Optional) Use 8985.1 if nil, else use GMRAFILE
- ;
- ; Output parameter:
- ; 1st '^' piece - VUID # or 0 if no VUID
- ; 2nd '^' piece - Coding system: "99VA8985.1" if VUID and GMRAFLSW=nil
- ; "99VA"_GMRAFILE if GMRAFLSW=1
- ; else = <site_VistA application file #> if no VUID
- N X S X=+$$GETVUID^XTID(GMRAFILE,GMRAFLD,GMRADATA),GMRAFLSW=$G(GMRAFLSW)
- I X S $P(X,U,2)="99VA"_$S(GMRAFLSW:GMRAFILE,1:"8985.1")
- E S $P(X,U,2)=$P(SITEPARM,U,6)_"_"_GMRAFILE
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAIAL1 7728 printed Feb 18, 2025@23:05:48 Page 2
- GMRAIAL1 ;BPOIFO/JG - BUILD HL7 ORU^R01 MESSAGE FOR ALLERGIES - PART 1 ; 17 Mar 2006 11:07 AM
- +1 ;;4.0;Adverse Reaction Tracking;**22,23,34**;Mar 29, 1996
- VALID ;;VDEF HL7 MESSAGE BUILDER
- +1 ; Creates HL7 V2.4 ORU^R01 message for allergy updates & assessments
- +2 ;
- +3 ; This routine uses the following IAs:
- +4 ; #4248 - VDEFEL calls (controlled)
- +5 ; #3630 - VAFCQRY calls (controlled)
- +6 ; #2196 - ^PS(50.416,IEN,0) (controlled)
- +7 ; #2574 - $$CLASS2^PSNAPIS (supported)
- +8 ; #4571 - ERR^VDEFREQ (controlled)
- +9 ; #4631 - XTID calls (supported)
- +10 ;
- +11 ; This routine is called at tag EN as a Function by VDEFREQ1
- +12 ;
- +13 ; This routine calls GMRAIAL2 for a portion of message
- +14 ;
- +15 QUIT
- +16 ;
- EN(EVIEN,KEY,VFLAG,OUT,MSHP) ; Entry point
- +1 ;
- +2 ; Inputs: EVIEN = IEN of VDEF Event in file 577
- +3 ; KEY - IEN of file to create message from
- +4 ; VFLAG - "V" for VistA HL7 destination (default)
- +5 ; OUT - target array, passed by reference
- +6 ; MSHP - Piece 4 contains message subtype
- +7 ;
- +8 ; Output: Two part string with parts separated by "^"
- +9 ; Part 1: "LM" - output in local array passed in "OUT" parameter
- +10 ; "GM" - output in ^TMP("HLS",$J)
- +11 ; Part 2: No longer used
- +12 ;
- +13 ;34
- NEW DFN,HLFS,HLCM,HLSC,HLRP,HLES,HLQ,ALRDATA,ADD,ALTYPE,XX
- +14 NEW DATA,VAL,I,S,X,Y,Z,X1,HL7RC,IEN,IEN1,OUTX,GMRAPID,ENTERR
- +15 NEW SEPF,SEPC,SEPR,SEPE,SEPS,ARRAY,CMP,SEQ,GMRAHL,RSLTSTA
- +16 NEW GMRAFILE,GMRAIENS,GMRAVUID
- +17 ;
- +18 ; Initialize stuff
- +19 KILL ^TMP("HLS",$JOB)
- SET S=0
- SET ARRAY="OUT("_"""HLS"""_",S)"
- SET TARGET="LM^"
- +20 MERGE GMRAHL=VDEFHL
- +21 ;
- +22 ; Determine whether API was Allergy Update or Assessment
- +23 SET ALTYPE=$SELECT($PIECE(MSHP,"~",4)="ALGY":1,$PIECE(MSHP,"~",4)="ADAS":2,1:1)
- +24 ;
- +25 ; Set up HL7 delimiters
- +26 SET HLCM=$EXTRACT(GMRAHL("ECH"))
- SET HLRP=$EXTRACT(GMRAHL("ECH"),2)
- SET HLSC=$EXTRACT(GMRAHL("ECH"),4)
- SET HLES=$EXTRACT(GMRAHL("ECH"),3)
- +27 SET HLFS=GMRAHL("FS")
- SET HLQ=GMRAHL("Q")
- SET HL7RC=HLES_HLFS_HLCM_HLRP_HLSC
- +28 DO SETDLMS^VDEFEL
- +29 ;
- +30 ; Get allergy data, patient ID, 'entered in error data'
- +31 ; based on whether it's an allergy update or an assessment
- +32 ; Allergy: ALTYPE=1, Assessment: ALTYPE=2
- +33 if ALTYPE=1
- Begin DoDot:1
- +34 SET ALRDATA=$GET(^GMR(120.8,KEY,0))
- +35 IF ALRDATA=""
- DO ERR^VDEFREQ("No data in file GMR(120.8) for IEN "_KEY)
- SET ZTSTOP=1
- QUIT
- +36 SET DFN=$PIECE(ALRDATA,U)
- SET ENTERR=$GET(^GMR(120.8,KEY,"ER"))
- +37 ;34
- SET RSLTSTA=$EXTRACT("FW",1+ENTERR)
- +38 IF $GET(^DPT(DFN,0))=""
- DO ERR^VDEFREQ("No data in file DPT for DFN "_DFN)
- SET ZTSTOP=1
- QUIT
- End DoDot:1
- if ZTSTOP=1
- GOTO EXIT
- +39 if ALTYPE=2
- Begin DoDot:1
- +40 SET ENTERR=""
- SET ALRDATA=$GET(^GMR(120.86,KEY,0))
- +41 IF $PIECE(ALRDATA,U,2)=""
- SET ENTERR=1
- +42 SET DFN=$SELECT(+ENTERR=1:KEY,1:$PIECE(ALRDATA,U))
- +43 IF $GET(^DPT(DFN,0))=""
- DO ERR^VDEFREQ("No data in file DPT for DFN "_DFN)
- SET ZTSTOP=1
- QUIT
- End DoDot:1
- if ZTSTOP=1
- GOTO EXIT
- +44 ;
- +45 ; Build segments for message in OUT, $P # = HL7 field #
- +46 ;
- +47 ; PID - Use MPI PID builder
- PID KILL GMRAPID
- SET OUTX=""
- SET S=1
- SET SEQ=""
- +1 DO BLDPID^VAFCQRY(DFN,1,SEQ,.GMRAPID,.GMRAHL)
- +2 FOR I=2:1
- if $GET(GMRAPID(I))=""
- QUIT
- SET GMRAPID(1,I-1)=GMRAPID(I)
- KILL GMRAPID(I)
- +3 MERGE OUTX=GMRAPID(1)
- KILL GMRAPID
- DO SAVE
- +4 ;
- +5 ; OBR
- OBR SET S=S+1
- SET OUTX=""
- SET $PIECE(OUTX,HLFS)=1
- +1 SET $PIECE(OUTX,HLFS,3)=KEY_HLCM_$PIECE(SITEPARM,U,6)_$SELECT(ALTYPE=1:"_120.8",ALTYPE=2:"_120.86")
- +2 SET $PIECE(OUTX,HLFS,4)=$PIECE("ALLERGY,ASSESSMENT",",",ALTYPE)_HLCM_HLCM_"L"
- +3 ;
- +4 ; Result Status
- +5 ;34
- SET $PIECE(OUTX,HLFS,25)=$EXTRACT("FE",1+ENTERR)
- +6 ;
- +7 ; Date/time reaction entered in system
- +8 SET $PIECE(OUTX,HLFS,7)=$$TS^VDEFEL($PIECE(ALRDATA,U,4))
- +9 ;
- +10 ; Originator for allergy
- +11 ;34
- SET XX=$PIECE(ALRDATA,U,$PIECE("5^3",U,ALTYPE))
- +12 ;Block added in 34
- IF XX'=""
- Begin DoDot:1
- +13 SET XX=$$XCN200^VDEFEL(XX)
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +14 FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +15 SET $PIECE(OUTX,HLFS,32)=XX
- End DoDot:1
- +16 if ALTYPE=2
- GOTO OBRX
- +17 ;
- +18 ; Repeating field of various person roles
- +19 ; Enterer, Verifier, Error User, ID Band Marker, Chart Marker
- +20 ; and associated dates
- +21 SET (X,Y,Z)=""
- ENT ;34
- SET XX=$PIECE(ALRDATA,U,5)
- if XX=""
- GOTO VER
- +1 ;34
- SET XX=$$XCN200^VDEFEL(XX)
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +2 ;34
- FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +3 ;34
- SET VAL=XX
- SET $PIECE(VAL,HLSC,8)="E"
- SET Z=VAL
- +4 SET $PIECE(Z,HLCM,2)=$$TS^VDEFEL($PIECE(ALRDATA,U,4))
- SET X=Z
- VER if $PIECE(ALRDATA,U,17)=""
- GOTO ERR
- +1 ;34
- SET XX=$$XCN200^VDEFEL($PIECE(ALRDATA,U,18))
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +2 ;34
- FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +3 ;34
- SET VAL=XX
- SET $PIECE(VAL,HLSC,8)="V"
- SET Z=VAL
- +4 SET $PIECE(Z,HLCM,2)=$$TS^VDEFEL($PIECE(ALRDATA,U,17))
- SET X=$GET(X)_HLRP_Z
- ERR ;34
- SET XX=+ENTERR
- if 'XX
- GOTO IDBM
- +1 ;34
- SET XX=$$XCN200^VDEFEL($PIECE(ENTERR,U,3))
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +2 ;34
- FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +3 ;34
- SET VAL=XX
- SET $PIECE(VAL,HLSC,8)="EE"
- SET Z=VAL
- +4 SET $PIECE(Z,HLCM,2)=$$TS^VDEFEL($PIECE(ENTERR,U,2))
- SET X=$GET(X)_HLRP_Z
- +5 ;
- +6 ; May be multiple entries for ID Band & Chart Marker persons
- IDBM if '$DATA(^GMR(120.8,KEY,14))
- GOTO CHRT
- +1 SET IEN1=0
- FOR
- SET IEN1=$ORDER(^GMR(120.8,KEY,14,IEN1))
- if '+IEN1
- QUIT
- Begin DoDot:1
- +2 ;34
- SET X1=$GET(^GMR(120.8,KEY,14,IEN1,0))
- +3 ;34
- SET XX=$$XCN200^VDEFEL($PIECE(X1,U,2))
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +4 ;34
- FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +5 ;34
- SET VAL=XX
- if VAL=""
- SET VAL=Y
- SET $PIECE(VAL,HLSC,8)="BM"
- SET Z=VAL
- +6 SET $PIECE(Z,HLCM,2)=$$TS^VDEFEL($PIECE(X1,U,1))
- SET X=$GET(X)_HLRP_Z
- End DoDot:1
- CHRT if '$DATA(^GMR(120.8,KEY,13))
- GOTO OBR1
- +1 SET IEN1=0
- FOR
- SET IEN1=$ORDER(^GMR(120.8,KEY,13,IEN1))
- if '+IEN1
- QUIT
- Begin DoDot:1
- +2 ;34
- SET X1=$GET(^GMR(120.8,KEY,13,IEN1,0))
- +3 ;34
- SET XX=$$XCN200^VDEFEL($PIECE(X1,U,2))
- SET XX=$TRANSLATE(XX,HLCM,HLSC)
- +4 ;34
- FOR II=2:1:7
- SET $PIECE(XX,SEPS,II)=$$HL7RC($PIECE(XX,SEPS,II))
- +5 ;34
- SET VAL=XX
- if VAL=""
- SET VAL=Y
- SET $PIECE(VAL,HLSC,8)="CM"
- SET Z=VAL
- +6 SET $PIECE(Z,HLCM,2)=$$TS^VDEFEL($PIECE(X1,U,1))
- SET X=$GET(X)_HLRP_Z
- End DoDot:1
- OBR1 SET $PIECE(OUTX,HLFS,34)=X
- +1 ;
- +2 ; Observed/Historical Indicator
- +3 SET X=$PIECE(ALRDATA,U,6)
- SET GMRAVUID=$$GETVUID(120.8,6,X)
- +4 SET VAL=$PIECE(GMRAVUID,U)_HLCM_$SELECT(X="o":"OBSERVED",X="h":"HISTORICAL",1:"")
- +5 SET VAL=VAL_HLCM_$PIECE(GMRAVUID,U,2)
- +6 SET $PIECE(OUTX,HLFS,47)=VAL
- OBRX SET OUTX="OBR"_HLFS_OUTX
- DO SAVE
- +1 ;
- +2 ; If the record is missing both the Reactant and the GMR Allergy
- +3 ; trap it as an error.
- +4 IF ALTYPE'=2
- IF $PIECE(ALRDATA,U,2)=""
- IF $PIECE(ALRDATA,U,3)=""
- DO ERR^VDEFREQ("Record is missing Reactant and GMR Allergy")
- SET ZTSTOP=1
- QUIT
- +5 ;
- +6 ; OK to continue, call GMRAIAL2 for the rest of the message
- CALL DO ENTRY^GMRAIAL2
- +1 ;
- +2 ; Done building segments
- EXIT QUIT TARGET
- +1 ;
- +2 ;
- +3 ; Place current string into message array.
- +4 ; Turn string into array if length >245.
- +5 ; Move local array to global if needed.
- SAVE NEW I
- +1 IF $PIECE(OUTX,HLFS)'="PID"
- IF $LENGTH(OUTX)>245
- Begin DoDot:1
- +2 KILL ADD
- SET ADD=$EXTRACT(OUTX,1,245)
- SET OUTX=$EXTRACT(OUTX,246,$LENGTH(OUTX))
- +3 FOR I=1:1
- SET ADD(I)=$EXTRACT(OUTX,1,245)
- SET OUTX=$EXTRACT(OUTX,246,$LENGTH(OUTX))
- if OUTX=""
- QUIT
- +4 KILL OUTX
- MERGE OUTX=ADD
- End DoDot:1
- +5 MERGE @ARRAY=OUTX
- +6 ;
- +7 ; Move local array to global if it's getting big.
- +8 IF $PIECE(TARGET,U)="LM"
- IF $STORAGE<16000
- Begin DoDot:1
- +9 KILL ^TMP("HLS",$JOB)
- MERGE ^TMP("HLS",$JOB)=OUT("HLS")
- KILL OUT("HLS")
- +10 SET $PIECE(TARGET,U)="GM"
- SET ARRAY="^TMP("_"""HLS"""_",$J,S)"
- End DoDot:1
- +11 KILL OUTX,ADD
- +12 QUIT
- +13 ;
- +14 ; Replace any HL7 coding chars. in strings with HL7 escape sequence
- +15 ; Input: X = data string
- HL7RC(X) NEW OCHR,RCHR,RCHRI,TYPE,I
- FOR TYPE="E","F","C","R","S"
- Begin DoDot:1
- +1 SET RCHRI=$SELECT(TYPE="E":1,TYPE="F":2,TYPE="C":3,TYPE="R":4,TYPE="S":5)
- +2 SET OCHR=$EXTRACT(HL7RC,RCHRI)
- SET RCHR=$EXTRACT("EFSRT",RCHRI)
- +3 if '$FIND(X,OCHR)
- QUIT
- +4 FOR I=1:1
- if $EXTRACT(X,I)=""
- QUIT
- IF $EXTRACT(X,I)=OCHR
- SET X=$EXTRACT(X,1,I-1)_HLES_RCHR_HLES_$EXTRACT(X,I+1,999)
- SET I=I+2
- End DoDot:1
- +5 QUIT X
- +6 ;
- +7 ; Get the VUID value and set up name of coding system
- GETVUID(GMRAFILE,GMRAFLD,GMRADATA,GMRAFLSW) ;
- +1 ; Input parameters:
- +2 ; GMRAFILE - VistA File #
- +3 ; GMRAFLD - Field # in GMRAFILE
- +4 ; GMRADATA - Reference value to look up VUID for
- +5 ; GMRAFLSW - (Optional) Use 8985.1 if nil, else use GMRAFILE
- +6 ;
- +7 ; Output parameter:
- +8 ; 1st '^' piece - VUID # or 0 if no VUID
- +9 ; 2nd '^' piece - Coding system: "99VA8985.1" if VUID and GMRAFLSW=nil
- +10 ; "99VA"_GMRAFILE if GMRAFLSW=1
- +11 ; else = <site_VistA application file #> if no VUID
- +12 NEW X
- SET X=+$$GETVUID^XTID(GMRAFILE,GMRAFLD,GMRADATA)
- SET GMRAFLSW=$GET(GMRAFLSW)
- +13 IF X
- SET $PIECE(X,U,2)="99VA"_$SELECT(GMRAFLSW:GMRAFILE,1:"8985.1")
- +14 IF '$TEST
- SET $PIECE(X,U,2)=$PIECE(SITEPARM,U,6)_"_"_GMRAFILE
- +15 QUIT X