PSULRHL2 ;HCIOFO/BH - File real time HL7 messages ; 3/30/11 10:14am
;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,17,18**;MARCH, 2005;Build 7
;
FILE Q ; quit for HLO - ALA
;
; * THIS CODE IS NEVER TO BE INVOKED AT A SITE!!! ***
; * IT SHOULD ONLY BE INSTALLED ON THE CMOP-NAT SERVER ***
;
Q
;
;***** parses then files the incoming HL7 message into the message
; global
;
;***** The following are present upon entry to this label
;
; HLNEXT M Code you can use to execute a $O through the segments of
; a message
;
; HLNODE The current segment in the message (initally set to null)
;
; HLQUIT If not greater than zero, indicates there are no more
; segments to $O through
;
;*****
;
N FAC,HLCS,HLCSS,HLECH,HLFILE,HLFS,I,I2,ID,IEN,J2
K HLFILE,X2
;
F I2=1:1 X HLNEXT Q:HLQUIT'>0 D
. S HLFILE(I2)=HLNODE,J2=0
. F S J2=$O(HLNODE(J2)) Q:'J2 S HLFILE(I2,J2)=HLNODE(J2)
;
S HLFILE="HLFILE"
;
I $D(@(HLFILE))<10 Q
;
;
I '$$PARAMS() Q
;
S IEN=$$DEMO() I 'IEN Q
;
D WRITE(IEN)
;
K X2,HLFILE
Q
;
;
WRITE(IEN) ;--- Find the OBR/OBX segments
;
N I,IEN1,IEN2,J,J1,PREV,QUIT,STR,STR1
S I=0
F S I=$O(@HLFILE@(I)) Q:I="" D
. S STR=@HLFILE@(I)
. S J=""
. F S J=$O(@HLFILE@(I,J)) Q:J="" S STR=STR_@HLFILE@(I,J)
. I $E(STR,1,3)="OBR" D
. . S IEN1=$$OBR(STR,IEN)
. . I 'IEN1 Q
. . S QUIT=0
. . F Q:QUIT S PREV=I,I=$O(@HLFILE@(I)) Q:I="" D
. . . S STR1=@HLFILE@(I)
. . . S J1=""
. . . F S J1=$O(@HLFILE@(I,J1)) Q:J1="" S STR1=STR1_@HLFILE@(I,J1)
. . . I $E(STR1,1,3)'="OBX" S QUIT=1 Q
. . . D OBX(STR1,IEN,IEN1)
. . S I=PREV
Q
;
;
ERROR(CODE,FAC,MESSAGE) ; Files any errors found within the processing
;
; Input:
;
; CODE Error Code
; FAC Facility number
; MESSAGE Optional parameter to help illustrate the error
;
;
N ARR,FDA,STR
I CODE=1 S STR=DT_": No patient DFN in the HL7 message ID: "_MESSAGE_" - Facility: "_FAC
;
I CODE=2 S STR=DT_": Fileman Update did not work for message ID: "_MESSAGE_" - Facility: "_FAC
;
I CODE=3 S STR=DT_": Could not update the OBR segment in message ID "_MESSAGE
;
I CODE=4 S STR=DT_": Could not update the OBX segment in message ID "_MESSAGE
;
S FDA(99999,"+1,",.01)=FAC
S FDA(99999,"+1,",2)=STR
D UPDATE^DIE("","FDA",)
Q
;
;
OBX(STR1,IEN,IEN1) ; Extracts required OBX fields and files into
; the global
;
N FDA2,IENS,INDEX,LABS,LOCAL,LOINCC,LOINCNME,MSG2,NLTCODE,NLTNAME,OUT2,RANGE,RESULT,UNITS,VALUE
;
S LABS=$P(STR1,HLFS,4)
F INDEX=3,6,9 D
. S VALUE=$P(LABS,HLCS,INDEX)
. I VALUE="99LRT" D
. . S LOCAL=$P(LABS,HLCS,INDEX-1)
. I VALUE="99NLT" D
. . S NLTCODE=$P(LABS,HLCS,INDEX-2)
. . S NLTNAME=$P(LABS,HLCS,INDEX-1)
. I VALUE="99LN" D
. . S LOINCC=$P(LABS,HLCS,INDEX-2)
. . S LOINCNME=$P(LABS,HLCS,INDEX-1)
;
S RESULT=$P(STR1,HLFS,6)
I $G(RESULTS)="" Q
S UNITS=$P(STR1,HLFS,7)
S RANGE=$P(STR1,HLFS,8)
;
S IENS="+1,"_IEN1_","_IEN_","
S FDA2(99999.11,IENS,.01)=RESULT
S FDA2(99999.11,IENS,.02)=$G(NLTCODE)
S FDA2(99999.11,IENS,.03)=$G(NLTNAME)
S FDA2(99999.11,IENS,.04)=$G(LOINCC)
S FDA2(99999.11,IENS,.05)=$G(LOINCNME)
S FDA2(99999.11,IENS,.06)=$G(LOCAL)
S FDA2(99999.11,IENS,2.01)=UNITS
S FDA2(99999.11,IENS,2.02)=RANGE
D UPDATE^DIE("","FDA2","OUT2","MSG2")
;
;I $D(MSG2) S ^TMP("PSUTEST",$J)=MSG2 D ERROR(4,FAC,ID_" IENs: "_IENS)
I $D(MSG2) D ERROR(4,FAC,ID_" IENs: "_IENS)
;
Q
;
;
;
OBR(STR,IEN) ; Extracts required OBR fields and files into the global
N DD,FDA1,MM,MSG1,OUT1,SPEC,SPECDATE,YY
S SPECDATE=+$P(STR,HLFS,8)
S MM=$E(SPECDATE,5,6),DD=$E(SPECDATE,7,8),YY=$E(SPECDATE,3,4)
S YY=$S($E(YY,1,1)=0:"3",1:"2")_YY,SPECDATE=YY_MM_DD
S SPEC=$P(STR,HLFS,16)
;
S FDA1(99999.01,"+1,"_IEN_",",.01)=SPEC
S FDA1(99999.01,"+1,"_IEN_",",.02)=SPECDATE
D UPDATE^DIE("","FDA1","OUT1","MSG1")
;
I $D(MSG1) D ERROR(3,FAC,ID_" IENs: "_IEN) Q 0
;
Q OUT1(1)
;
;
PARAMS() ; Get HL7 Parameters and facility # from the MSH segment
N CNT,J2,QUIT,REC
S (QUIT,CNT)=0
F S CNT=$O(@HLFILE@(CNT)) Q:'CNT!(QUIT) D
. S REC=@HLFILE@(CNT)
. S J2=""
. F S J2=$O(@HLFILE@(CNT,J2)) Q:J2="" S REC=REC_@HLFILE@(CNT,J2)
. I $E(REC,1,3)="MSH" D Q
. . S HLFS=$E(REC,4,4)
. . S HLECH=$P(REC,HLFS,2)
. . S HLCS=$E(HLECH,1,1)
. . S HLCSS=$E(HLECH,2,2)
. . S FAC=$P(REC,HLFS,4),FAC=$P(FAC,HLCS,1)
. . S ID=$P(REC,HLFS,10)
. . S QUIT=1
I $G(FAC)="" Q 0
Q 1
;
DEMO() ; Get the demographic data and file a zero node entry in the
; message global
;
N CNT,DFN,END,FDA,I,ICN,IDSTR,J3,MSG,OUT,QPID,QORC,QUIT,REC,SUB,SSN,STA5A
S (ICN,SSN,DFN,STA5A)=""
S (QPID,QORC,QUIT,CNT)=0
F S CNT=$O(@HLFILE@(CNT)) Q:'CNT!(QUIT) D
. S REC=@HLFILE@(CNT)
. S J3=""
. F S J3=$O(@HLFILE@(CNT,J3)) Q:J3="" S REC=REC_@HLFILE@(CNT,J3)
. I $E(REC,1,3)="PID" D Q
. . S IDSTR=$P(REC,HLFS,4),END=0
. . ;
. . F I=1:1 Q:END D
. . . S SUB=$P(IDSTR,HLCSS,I)
. . . I SUB="" S END=1 Q
. . . I $P(SUB,HLCS,5)="NI" D
. . . . I $P(SUB,HLCS,8)'="" Q
. . . . S ICN=$P(SUB,HLCS,1),ICN=$P(ICN,"V",1)
. . . . ;
. . . . ;PSU*4*17 Don't overwrite SSN with ""
. . . I $P(SUB,HLCS,5)="SS" D
. . . . S SSN=$S($G(SSN):SSN,1:$P(SUB,HLCS,1))
. . . . ;
. . . I $P(SUB,HLCS,5)="PI" D
. . . . S DFN=$P(SUB,HLCS,1)
. . S QPID=1
. ;*18 Get Station#
. I $E(REC,1,3)="ORC" D
. . S STA5A=$P(REC,HLFS,11),STA5A=$P(STA5A,HLCS,14),QORC=1
. I QPID,QORC S QUIT=1
;
I DFN="" D ERROR(1,FAC,ID) Q 0
;
K FDA,OUT,MSG
;
S FDA(99999,"+1,",.02)=DFN
S FDA(99999,"+1,",.04)=ICN
S FDA(99999,"+1,",.05)=SSN
S FDA(99999,"+1,",.06)=STA5A
S FDA(99999,"+1,",.01)=FAC
D UPDATE^DIE("","FDA","OUT","MSG")
;
I $D(MSG) D ERROR(2,FAC,ID) Q 0
;
Q OUT(1)
;
;
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULRHL2 5877 printed Sep 23, 2025@20:03:40 Page 2
PSULRHL2 ;HCIOFO/BH - File real time HL7 messages ; 3/30/11 10:14am
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,17,18**;MARCH, 2005;Build 7
+2 ;
FILE ; quit for HLO - ALA
QUIT
+1 ;
+2 ; * THIS CODE IS NEVER TO BE INVOKED AT A SITE!!! ***
+3 ; * IT SHOULD ONLY BE INSTALLED ON THE CMOP-NAT SERVER ***
+4 ;
+5 QUIT
+6 ;
+7 ;***** parses then files the incoming HL7 message into the message
+8 ; global
+9 ;
+10 ;***** The following are present upon entry to this label
+11 ;
+12 ; HLNEXT M Code you can use to execute a $O through the segments of
+13 ; a message
+14 ;
+15 ; HLNODE The current segment in the message (initally set to null)
+16 ;
+17 ; HLQUIT If not greater than zero, indicates there are no more
+18 ; segments to $O through
+19 ;
+20 ;*****
+21 ;
+22 NEW FAC,HLCS,HLCSS,HLECH,HLFILE,HLFS,I,I2,ID,IEN,J2
+23 KILL HLFILE,X2
+24 ;
+25 FOR I2=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+26 SET HLFILE(I2)=HLNODE
SET J2=0
+27 FOR
SET J2=$ORDER(HLNODE(J2))
if 'J2
QUIT
SET HLFILE(I2,J2)=HLNODE(J2)
End DoDot:1
+28 ;
+29 SET HLFILE="HLFILE"
+30 ;
+31 IF $DATA(@(HLFILE))<10
QUIT
+32 ;
+33 ;
+34 IF '$$PARAMS()
QUIT
+35 ;
+36 SET IEN=$$DEMO()
IF 'IEN
QUIT
+37 ;
+38 DO WRITE(IEN)
+39 ;
+40 KILL X2,HLFILE
+41 QUIT
+42 ;
+43 ;
WRITE(IEN) ;--- Find the OBR/OBX segments
+1 ;
+2 NEW I,IEN1,IEN2,J,J1,PREV,QUIT,STR,STR1
+3 SET I=0
+4 FOR
SET I=$ORDER(@HLFILE@(I))
if I=""
QUIT
Begin DoDot:1
+5 SET STR=@HLFILE@(I)
+6 SET J=""
+7 FOR
SET J=$ORDER(@HLFILE@(I,J))
if J=""
QUIT
SET STR=STR_@HLFILE@(I,J)
+8 IF $EXTRACT(STR,1,3)="OBR"
Begin DoDot:2
+9 SET IEN1=$$OBR(STR,IEN)
+10 IF 'IEN1
QUIT
+11 SET QUIT=0
+12 FOR
if QUIT
QUIT
SET PREV=I
SET I=$ORDER(@HLFILE@(I))
if I=""
QUIT
Begin DoDot:3
+13 SET STR1=@HLFILE@(I)
+14 SET J1=""
+15 FOR
SET J1=$ORDER(@HLFILE@(I,J1))
if J1=""
QUIT
SET STR1=STR1_@HLFILE@(I,J1)
+16 IF $EXTRACT(STR1,1,3)'="OBX"
SET QUIT=1
QUIT
+17 DO OBX(STR1,IEN,IEN1)
End DoDot:3
+18 SET I=PREV
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;
ERROR(CODE,FAC,MESSAGE) ; Files any errors found within the processing
+1 ;
+2 ; Input:
+3 ;
+4 ; CODE Error Code
+5 ; FAC Facility number
+6 ; MESSAGE Optional parameter to help illustrate the error
+7 ;
+8 ;
+9 NEW ARR,FDA,STR
+10 IF CODE=1
SET STR=DT_": No patient DFN in the HL7 message ID: "_MESSAGE_" - Facility: "_FAC
+11 ;
+12 IF CODE=2
SET STR=DT_": Fileman Update did not work for message ID: "_MESSAGE_" - Facility: "_FAC
+13 ;
+14 IF CODE=3
SET STR=DT_": Could not update the OBR segment in message ID "_MESSAGE
+15 ;
+16 IF CODE=4
SET STR=DT_": Could not update the OBX segment in message ID "_MESSAGE
+17 ;
+18 SET FDA(99999,"+1,",.01)=FAC
+19 SET FDA(99999,"+1,",2)=STR
+20 DO UPDATE^DIE("","FDA",)
+21 QUIT
+22 ;
+23 ;
OBX(STR1,IEN,IEN1) ; Extracts required OBX fields and files into
+1 ; the global
+2 ;
+3 NEW FDA2,IENS,INDEX,LABS,LOCAL,LOINCC,LOINCNME,MSG2,NLTCODE,NLTNAME,OUT2,RANGE,RESULT,UNITS,VALUE
+4 ;
+5 SET LABS=$PIECE(STR1,HLFS,4)
+6 FOR INDEX=3,6,9
Begin DoDot:1
+7 SET VALUE=$PIECE(LABS,HLCS,INDEX)
+8 IF VALUE="99LRT"
Begin DoDot:2
+9 SET LOCAL=$PIECE(LABS,HLCS,INDEX-1)
End DoDot:2
+10 IF VALUE="99NLT"
Begin DoDot:2
+11 SET NLTCODE=$PIECE(LABS,HLCS,INDEX-2)
+12 SET NLTNAME=$PIECE(LABS,HLCS,INDEX-1)
End DoDot:2
+13 IF VALUE="99LN"
Begin DoDot:2
+14 SET LOINCC=$PIECE(LABS,HLCS,INDEX-2)
+15 SET LOINCNME=$PIECE(LABS,HLCS,INDEX-1)
End DoDot:2
End DoDot:1
+16 ;
+17 SET RESULT=$PIECE(STR1,HLFS,6)
+18 IF $GET(RESULTS)=""
QUIT
+19 SET UNITS=$PIECE(STR1,HLFS,7)
+20 SET RANGE=$PIECE(STR1,HLFS,8)
+21 ;
+22 SET IENS="+1,"_IEN1_","_IEN_","
+23 SET FDA2(99999.11,IENS,.01)=RESULT
+24 SET FDA2(99999.11,IENS,.02)=$GET(NLTCODE)
+25 SET FDA2(99999.11,IENS,.03)=$GET(NLTNAME)
+26 SET FDA2(99999.11,IENS,.04)=$GET(LOINCC)
+27 SET FDA2(99999.11,IENS,.05)=$GET(LOINCNME)
+28 SET FDA2(99999.11,IENS,.06)=$GET(LOCAL)
+29 SET FDA2(99999.11,IENS,2.01)=UNITS
+30 SET FDA2(99999.11,IENS,2.02)=RANGE
+31 DO UPDATE^DIE("","FDA2","OUT2","MSG2")
+32 ;
+33 ;I $D(MSG2) S ^TMP("PSUTEST",$J)=MSG2 D ERROR(4,FAC,ID_" IENs: "_IENS)
+34 IF $DATA(MSG2)
DO ERROR(4,FAC,ID_" IENs: "_IENS)
+35 ;
+36 QUIT
+37 ;
+38 ;
+39 ;
OBR(STR,IEN) ; Extracts required OBR fields and files into the global
+1 NEW DD,FDA1,MM,MSG1,OUT1,SPEC,SPECDATE,YY
+2 SET SPECDATE=+$PIECE(STR,HLFS,8)
+3 SET MM=$EXTRACT(SPECDATE,5,6)
SET DD=$EXTRACT(SPECDATE,7,8)
SET YY=$EXTRACT(SPECDATE,3,4)
+4 SET YY=$SELECT($EXTRACT(YY,1,1)=0:"3",1:"2")_YY
SET SPECDATE=YY_MM_DD
+5 SET SPEC=$PIECE(STR,HLFS,16)
+6 ;
+7 SET FDA1(99999.01,"+1,"_IEN_",",.01)=SPEC
+8 SET FDA1(99999.01,"+1,"_IEN_",",.02)=SPECDATE
+9 DO UPDATE^DIE("","FDA1","OUT1","MSG1")
+10 ;
+11 IF $DATA(MSG1)
DO ERROR(3,FAC,ID_" IENs: "_IEN)
QUIT 0
+12 ;
+13 QUIT OUT1(1)
+14 ;
+15 ;
PARAMS() ; Get HL7 Parameters and facility # from the MSH segment
+1 NEW CNT,J2,QUIT,REC
+2 SET (QUIT,CNT)=0
+3 FOR
SET CNT=$ORDER(@HLFILE@(CNT))
if 'CNT!(QUIT)
QUIT
Begin DoDot:1
+4 SET REC=@HLFILE@(CNT)
+5 SET J2=""
+6 FOR
SET J2=$ORDER(@HLFILE@(CNT,J2))
if J2=""
QUIT
SET REC=REC_@HLFILE@(CNT,J2)
+7 IF $EXTRACT(REC,1,3)="MSH"
Begin DoDot:2
+8 SET HLFS=$EXTRACT(REC,4,4)
+9 SET HLECH=$PIECE(REC,HLFS,2)
+10 SET HLCS=$EXTRACT(HLECH,1,1)
+11 SET HLCSS=$EXTRACT(HLECH,2,2)
+12 SET FAC=$PIECE(REC,HLFS,4)
SET FAC=$PIECE(FAC,HLCS,1)
+13 SET ID=$PIECE(REC,HLFS,10)
+14 SET QUIT=1
End DoDot:2
QUIT
End DoDot:1
+15 IF $GET(FAC)=""
QUIT 0
+16 QUIT 1
+17 ;
DEMO() ; Get the demographic data and file a zero node entry in the
+1 ; message global
+2 ;
+3 NEW CNT,DFN,END,FDA,I,ICN,IDSTR,J3,MSG,OUT,QPID,QORC,QUIT,REC,SUB,SSN,STA5A
+4 SET (ICN,SSN,DFN,STA5A)=""
+5 SET (QPID,QORC,QUIT,CNT)=0
+6 FOR
SET CNT=$ORDER(@HLFILE@(CNT))
if 'CNT!(QUIT)
QUIT
Begin DoDot:1
+7 SET REC=@HLFILE@(CNT)
+8 SET J3=""
+9 FOR
SET J3=$ORDER(@HLFILE@(CNT,J3))
if J3=""
QUIT
SET REC=REC_@HLFILE@(CNT,J3)
+10 IF $EXTRACT(REC,1,3)="PID"
Begin DoDot:2
+11 SET IDSTR=$PIECE(REC,HLFS,4)
SET END=0
+12 ;
+13 FOR I=1:1
if END
QUIT
Begin DoDot:3
+14 SET SUB=$PIECE(IDSTR,HLCSS,I)
+15 IF SUB=""
SET END=1
QUIT
+16 IF $PIECE(SUB,HLCS,5)="NI"
Begin DoDot:4
+17 IF $PIECE(SUB,HLCS,8)'=""
QUIT
+18 SET ICN=$PIECE(SUB,HLCS,1)
SET ICN=$PIECE(ICN,"V",1)
+19 ;
+20 ;PSU*4*17 Don't overwrite SSN with ""
End DoDot:4
+21 IF $PIECE(SUB,HLCS,5)="SS"
Begin DoDot:4
+22 SET SSN=$SELECT($GET(SSN):SSN,1:$PIECE(SUB,HLCS,1))
+23 ;
End DoDot:4
+24 IF $PIECE(SUB,HLCS,5)="PI"
Begin DoDot:4
+25 SET DFN=$PIECE(SUB,HLCS,1)
End DoDot:4
End DoDot:3
+26 SET QPID=1
End DoDot:2
QUIT
+27 ;*18 Get Station#
+28 IF $EXTRACT(REC,1,3)="ORC"
Begin DoDot:2
+29 SET STA5A=$PIECE(REC,HLFS,11)
SET STA5A=$PIECE(STA5A,HLCS,14)
SET QORC=1
End DoDot:2
+30 IF QPID
IF QORC
SET QUIT=1
End DoDot:1
+31 ;
+32 IF DFN=""
DO ERROR(1,FAC,ID)
QUIT 0
+33 ;
+34 KILL FDA,OUT,MSG
+35 ;
+36 SET FDA(99999,"+1,",.02)=DFN
+37 SET FDA(99999,"+1,",.04)=ICN
+38 SET FDA(99999,"+1,",.05)=SSN
+39 SET FDA(99999,"+1,",.06)=STA5A
+40 SET FDA(99999,"+1,",.01)=FAC
+41 DO UPDATE^DIE("","FDA","OUT","MSG")
+42 ;
+43 IF $DATA(MSG)
DO ERROR(2,FAC,ID)
QUIT 0
+44 ;
+45 QUIT OUT(1)
+46 ;
+47 ;
+48 QUIT
+49 ;
+50 ;
