- PSULRHL2 ;HCIOFO/BH - File real time HL7 messages ; 24 Aug 2005 5:23 PM
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005
- ;
- 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,QUIT,REC,SUB,SSN
- S (ICN,SSN,DFN)=""
- S (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)
- . . . . ;
- . . . I $P(SUB,HLCS,5)="SS" D
- . . . . S SSN=$P(SUB,HLCS,1)
- . . . . ;
- . . . I $P(SUB,HLCS,5)="PI" D
- . . . . S DFN=$P(SUB,HLCS,1)
- . . 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,",.01)=FAC
- D UPDATE^DIE("","FDA","OUT","MSG")
- ;
- I $D(MSG) D ERROR(2,FAC,ID) Q 0
- ;
- Q OUT(1)
- ;
- ;
- Q
- ;
- ;
- PSULRHL2 ;HCIOFO/BH - File real time HL7 messages ; 24 Aug 2005 5:23 PM
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005
- +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,QUIT,REC,SUB,SSN
- +4 SET (ICN,SSN,DFN)=""
- +5 SET (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 ;
- End DoDot:4
- +20 IF $PIECE(SUB,HLCS,5)="SS"
- Begin DoDot:4
- +21 SET SSN=$PIECE(SUB,HLCS,1)
- +22 ;
- End DoDot:4
- +23 IF $PIECE(SUB,HLCS,5)="PI"
- Begin DoDot:4
- +24 SET DFN=$PIECE(SUB,HLCS,1)
- End DoDot:4
- End DoDot:3
- +25 SET QUIT=1
- End DoDot:2
- QUIT
- End DoDot:1
- +26 ;
- +27 IF DFN=""
- DO ERROR(1,FAC,ID)
- QUIT 0
- +28 ;
- +29 KILL FDA,OUT,MSG
- +30 ;
- +31 SET FDA(99999,"+1,",.02)=DFN
- +32 SET FDA(99999,"+1,",.04)=ICN
- +33 SET FDA(99999,"+1,",.05)=SSN
- +34 SET FDA(99999,"+1,",.01)=FAC
- +35 DO UPDATE^DIE("","FDA","OUT","MSG")
- +36 ;
- +37 IF $DATA(MSG)
- DO ERROR(2,FAC,ID)
- QUIT 0
- +38 ;
- +39 QUIT OUT(1)
- +40 ;
- +41 ;
- +42 QUIT
- +43 ;
- +44 ;
