Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXCRD

IBARXCRD.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Receives from Cerner the IBARXC-QRYRESP - DSR^Q03
  1. ; processes Cerner seeding data, parse and save transactions
  1. ;
  1. EN(ICN) ;PRIMARY ENTRY POINT
  1. ;
  1. N MSG,HDR,SEG,XXX,DFN
  1. S DFN=$$DFN^IBARXMU(ICN)
  1. S XXX=$$STARTMSG^HLOPRS(.MSG,HLMSGIEN,.HDR)
  1. S XXX="" F S XXX=$$NEXTSEG^HLOPRS(.MSG,.SEG) Q:$G(SEG("SEGMENT TYPE"))="" D @SEG(0) ;("SEGMENT TYPE")
  1. G END
  1. Q
  1. ;
  1. MSA ;PARSE MSA SEGMENT
  1. Q
  1. QRD ;PARSE QRD SEGMENT
  1. Q
  1. QRF ;PARSE QRF SEGMENT
  1. Q
  1. DSP ;PARSE THE DSP SEGMENT
  1. N TRANSX,TRANS,X,TRANSDT,STAT,DESC,DESC1,DESC2,DESC3,DLEN,RXNUM
  1. N PATLOC,PARENT,I,TCHRG,BILLED,UNBILLED,UNITS,IBD,IENS,ACTTYPE,GOOD
  1. N CHECK,IBD1,IBX,IEN
  1. ;
  1. S I=1 F S I=$O(SEG(3,1,I)) Q:I="" D
  1. . S TRANSX=$G(SEG(3,1,2,1)) ;TRANSACTION ID
  1. . S TRANS=$E($P(TRANSX,"-",1),1,3)_"-"_$P(TRANSX,"-",2)
  1. . S X=$G(SEG(3,1,4,1))
  1. . S TRANSDT="3"_$E(X,3,4)_$E(X,5,8)
  1. . S STAT=$G(SEG(3,1,7,1)) ;trans type
  1. . S DESC=$G(SEG(3,1,10,1)) ;Brief description
  1. . I $D(DESC) D
  1. . . ;Truncate the middle value and not the rxnum or units
  1. . . S DESC1=$P(DESC,"-",1),DESC2=$P(DESC,"-",2),DESC3=$P(DESC,"-",$L(DESC,"-")) ;DESC may have more than 3 pieces
  1. . . S DLEN=(20-2-($L(DESC1_DESC3)))
  1. . . S DESC=DESC1_"-"_$E(DESC2,1,DLEN)_"-"_DESC3
  1. . S RXNUM=$G(SEG(3,1,11,1)) ;prescription number
  1. . S TCHRG=+$G(SEG(3,1,12,1)) ;total charge
  1. . S BILLED=+$G(SEG(3,1,13,1)) ;billed amount
  1. . S UNBILLED=+$G(SEG(3,1,14,1)) ;unbilled amount
  1. . S GOOD=0 D ;Do not file transactions with zero values
  1. . . S:BILLED'=0 GOOD=1
  1. . . S:UNBILLED'=0 GOOD=1
  1. . . S:TCHRG'=0 GOOD=1
  1. . Q:'GOOD
  1. . S UNITS=$G(SEG(3,1,15,1)) ;Units
  1. . S PARENT=$G(SEG(3,1,17,1)) ;Parent Transaction
  1. . I PARENT["CRNR" S PARENT=$TR(PARENT,"CRNR","") ;Remove CRNR from Cerner
  1. . I $G(PARENT)="" S PARENT=TRANS
  1. . S PATLOC=$G(SEG(3,1,18,1)) ;patient location
  1. . S CHECK=0,CHECK=$$DBLCHK(CHECK)
  1. . D:'CHECK SAVE
  1. . Q
  1. Q
  1. ;
  1. SAVE ;SAVE THE MESSAGE DATA TO 354.71
  1. S IBD=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$G(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
  1. S IBD=IBD_"^"_+TCHRG_"^"_DESC_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED_"^"_$P(PATLOC,"^",1)
  1. S IENS=$$ADD^IBARXMN(DFN,IBD)
  1. Q
  1. ;
  1. END ;KILL LOCAL VARIABLES AND QUIT
  1. Q
  1. ;
  1. 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
  1. ;Build MSH from existing MSH
  1. Q
  1. ;
  1. DBLCHK(CHECK) ;CHECK FOR A DUPLICATE ENTRY
  1. S CHECK=0
  1. I '$D(^IBAM(354.71,"B",TRANS)) Q CHECK
  1. S IEN=0,IEN=$O(^IBAM(354.71,"B",TRANS,IEN))
  1. 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)
  1. S IBD1=TRANS_"^"_DFN_"^"_TRANSDT_"^"_$G(ACTTYPE)_"^"_STAT_"^"_RXNUM_"^"_UNITS
  1. S IBD1=IBD1_"^"_+TCHRG_"^"_PARENT_"^"_+BILLED_"^"_+UNBILLED
  1. S CHECK=$S(IBX=IBD1:1,1:0)
  1. Q CHECK