- IBARXCRD ;ALB/CLT-CERNER RXCOPAY RECEIVE DSR MESSAGE ; 14 May 2021 1:31 PM
- ;;2.0;INTEGRATED BILLING;**676**;21-MAR-94;Build 34
- ;
- ; Receives from Cerner the IBARXC-QRYRESP - DSR^Q03
- ; processes Cerner seeding data, parse and save transactions
- ;
- EN(ICN) ;PRIMARY ENTRY POINT
- ;
- N MSG,HDR,SEG,XXX,DFN
- S DFN=$$DFN^IBARXMU(ICN)
- S XXX=$$STARTMSG^HLOPRS(.MSG,HLMSGIEN,.HDR)
- S XXX="" F S XXX=$$NEXTSEG^HLOPRS(.MSG,.SEG) Q:$G(SEG("SEGMENT TYPE"))="" D @SEG(0) ;("SEGMENT TYPE")
- G END
- Q
- ;
- MSA ;PARSE MSA SEGMENT
- Q
- QRD ;PARSE QRD SEGMENT
- Q
- QRF ;PARSE QRF SEGMENT
- Q
- DSP ;PARSE THE DSP SEGMENT
- N TRANSX,TRANS,X,TRANSDT,STAT,DESC,DESC1,DESC2,DESC3,DLEN,RXNUM
- N PATLOC,PARENT,I,TCHRG,BILLED,UNBILLED,UNITS,IBD,IENS,ACTTYPE,GOOD
- N CHECK,IBD1,IBX,IEN
- ;
- S I=1 F S I=$O(SEG(3,1,I)) Q:I="" D
- . S TRANSX=$G(SEG(3,1,2,1)) ;TRANSACTION ID
- . S TRANS=$E($P(TRANSX,"-",1),1,3)_"-"_$P(TRANSX,"-",2)
- . S X=$G(SEG(3,1,4,1))
- . S TRANSDT="3"_$E(X,3,4)_$E(X,5,8)
- . S STAT=$G(SEG(3,1,7,1)) ;trans type
- . S DESC=$G(SEG(3,1,10,1)) ;Brief description
- . I $D(DESC) D
- . . ;Truncate the middle value and not the rxnum or units
- . . S DESC1=$P(DESC,"-",1),DESC2=$P(DESC,"-",2),DESC3=$P(DESC,"-",$L(DESC,"-")) ;DESC may have more than 3 pieces
- . . S DLEN=(20-2-($L(DESC1_DESC3)))
- . . S DESC=DESC1_"-"_$E(DESC2,1,DLEN)_"-"_DESC3
- . S RXNUM=$G(SEG(3,1,11,1)) ;prescription number
- . S TCHRG=+$G(SEG(3,1,12,1)) ;total charge
- . S BILLED=+$G(SEG(3,1,13,1)) ;billed amount
- . S UNBILLED=+$G(SEG(3,1,14,1)) ;unbilled amount
- . S GOOD=0 D ;Do not file transactions with zero values
- . . S:BILLED'=0 GOOD=1
- . . S:UNBILLED'=0 GOOD=1
- . . S:TCHRG'=0 GOOD=1
- . Q:'GOOD
- . S UNITS=$G(SEG(3,1,15,1)) ;Units
- . S PARENT=$G(SEG(3,1,17,1)) ;Parent Transaction
- . I PARENT["CRNR" S PARENT=$TR(PARENT,"CRNR","") ;Remove CRNR from Cerner
- . I $G(PARENT)="" S PARENT=TRANS
- . S PATLOC=$G(SEG(3,1,18,1)) ;patient location
- . S CHECK=0,CHECK=$$DBLCHK(CHECK)
- . D:'CHECK SAVE
- . Q
- Q
- ;
- SAVE ;SAVE THE MESSAGE DATA TO 354.71
- S IBD=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$G(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
- S IBD=IBD_"^"_+TCHRG_"^"_DESC_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED_"^"_$P(PATLOC,"^",1)
- S IENS=$$ADD^IBARXMN(DFN,IBD)
- Q
- ;
- END ;KILL LOCAL VARIABLES AND QUIT
- Q
- ;
- ESEND ;Error response something was not passed in or didn't match
- ;This is a recieving utility. We need to change to return a message with the error
- ;Build MSH from existing MSH
- Q
- ;
- DBLCHK(CHECK) ;CHECK FOR A DUPLICATE ENTRY
- S CHECK=0
- I '$D(^IBAM(354.71,"B",TRANS)) Q CHECK
- S IEN=0,IEN=$O(^IBAM(354.71,"B",TRANS,IEN))
- S IBX=$P(^IBAM(354.71,IEN,0),"^",1,8)_"^"_$P(^IBAM(354.71,$P(^IBAM(354.71,IEN,0),"^",10),0),"^",1)_"^"_$P(^IBAM(354.71,IEN,0),"^",11,12)
- S IBD1=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$G(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
- S IBD1=IBD1_"^"_+TCHRG_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED
- S CHECK=$S(IBX=IBD1:1,1:0)
- Q CHECK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXCRD 2978 printed Feb 18, 2025@23:33:27 Page 2
- IBARXCRD ;ALB/CLT-CERNER RXCOPAY RECEIVE DSR MESSAGE ; 14 May 2021 1:31 PM
- +1 ;;2.0;INTEGRATED BILLING;**676**;21-MAR-94;Build 34
- +2 ;
- +3 ; Receives from Cerner the IBARXC-QRYRESP - DSR^Q03
- +4 ; processes Cerner seeding data, parse and save transactions
- +5 ;
- EN(ICN) ;PRIMARY ENTRY POINT
- +1 ;
- +2 NEW MSG,HDR,SEG,XXX,DFN
- +3 SET DFN=$$DFN^IBARXMU(ICN)
- +4 SET XXX=$$STARTMSG^HLOPRS(.MSG,HLMSGIEN,.HDR)
- +5 ;("SEGMENT TYPE")
- SET XXX=""
- FOR
- SET XXX=$$NEXTSEG^HLOPRS(.MSG,.SEG)
- if $GET(SEG("SEGMENT TYPE"))=""
- QUIT
- DO @SEG(0)
- +6 GOTO END
- +7 QUIT
- +8 ;
- MSA ;PARSE MSA SEGMENT
- +1 QUIT
- QRD ;PARSE QRD SEGMENT
- +1 QUIT
- QRF ;PARSE QRF SEGMENT
- +1 QUIT
- DSP ;PARSE THE DSP SEGMENT
- +1 NEW TRANSX,TRANS,X,TRANSDT,STAT,DESC,DESC1,DESC2,DESC3,DLEN,RXNUM
- +2 NEW PATLOC,PARENT,I,TCHRG,BILLED,UNBILLED,UNITS,IBD,IENS,ACTTYPE,GOOD
- +3 NEW CHECK,IBD1,IBX,IEN
- +4 ;
- +5 SET I=1
- FOR
- SET I=$ORDER(SEG(3,1,I))
- if I=""
- QUIT
- Begin DoDot:1
- +6 ;TRANSACTION ID
- SET TRANSX=$GET(SEG(3,1,2,1))
- +7 SET TRANS=$EXTRACT($PIECE(TRANSX,"-",1),1,3)_"-"_$PIECE(TRANSX,"-",2)
- +8 SET X=$GET(SEG(3,1,4,1))
- +9 SET TRANSDT="3"_$EXTRACT(X,3,4)_$EXTRACT(X,5,8)
- +10 ;trans type
- SET STAT=$GET(SEG(3,1,7,1))
- +11 ;Brief description
- SET DESC=$GET(SEG(3,1,10,1))
- +12 IF $DATA(DESC)
- Begin DoDot:2
- +13 ;Truncate the middle value and not the rxnum or units
- +14 ;DESC may have more than 3 pieces
- SET DESC1=$PIECE(DESC,"-",1)
- SET DESC2=$PIECE(DESC,"-",2)
- SET DESC3=$PIECE(DESC,"-",$LENGTH(DESC,"-"))
- +15 SET DLEN=(20-2-($LENGTH(DESC1_DESC3)))
- +16 SET DESC=DESC1_"-"_$EXTRACT(DESC2,1,DLEN)_"-"_DESC3
- End DoDot:2
- +17 ;prescription number
- SET RXNUM=$GET(SEG(3,1,11,1))
- +18 ;total charge
- SET TCHRG=+$GET(SEG(3,1,12,1))
- +19 ;billed amount
- SET BILLED=+$GET(SEG(3,1,13,1))
- +20 ;unbilled amount
- SET UNBILLED=+$GET(SEG(3,1,14,1))
- +21 ;Do not file transactions with zero values
- SET GOOD=0
- Begin DoDot:2
- +22 if BILLED'=0
- SET GOOD=1
- +23 if UNBILLED'=0
- SET GOOD=1
- +24 if TCHRG'=0
- SET GOOD=1
- End DoDot:2
- +25 if 'GOOD
- QUIT
- +26 ;Units
- SET UNITS=$GET(SEG(3,1,15,1))
- +27 ;Parent Transaction
- SET PARENT=$GET(SEG(3,1,17,1))
- +28 ;Remove CRNR from Cerner
- IF PARENT["CRNR"
- SET PARENT=$TRANSLATE(PARENT,"CRNR","")
- +29 IF $GET(PARENT)=""
- SET PARENT=TRANS
- +30 ;patient location
- SET PATLOC=$GET(SEG(3,1,18,1))
- +31 SET CHECK=0
- SET CHECK=$$DBLCHK(CHECK)
- +32 if 'CHECK
- DO SAVE
- +33 QUIT
- End DoDot:1
- +34 QUIT
- +35 ;
- SAVE ;SAVE THE MESSAGE DATA TO 354.71
- +1 SET IBD=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$GET(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
- +2 SET IBD=IBD_"^"_+TCHRG_"^"_DESC_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED_"^"_$PIECE(PATLOC,"^",1)
- +3 SET IENS=$$ADD^IBARXMN(DFN,IBD)
- +4 QUIT
- +5 ;
- END ;KILL LOCAL VARIABLES AND QUIT
- +1 QUIT
- +2 ;
- ESEND ;Error response something was not passed in or didn't match
- +1 ;This is a recieving utility. We need to change to return a message with the error
- +2 ;Build MSH from existing MSH
- +3 QUIT
- +4 ;
- DBLCHK(CHECK) ;CHECK FOR A DUPLICATE ENTRY
- +1 SET CHECK=0
- +2 IF '$DATA(^IBAM(354.71,"B",TRANS))
- QUIT CHECK
- +3 SET IEN=0
- SET IEN=$ORDER(^IBAM(354.71,"B",TRANS,IEN))
- +4 SET IBX=$PIECE(^IBAM(354.71,IEN,0),"^",1,8)_"^"_$PIECE(^IBAM(354.71,$PIECE(^IBAM(354.71,IEN,0),"^",10),0),"^",1)_"^"_$PIECE(^IBAM(354.71,IEN,0),"^",11,12)
- +5 SET IBD1=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$GET(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
- +6 SET IBD1=IBD1_"^"_+TCHRG_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED
- +7 SET CHECK=$SELECT(IBX=IBD1:1,1:0)
- +8 QUIT CHECK