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

IBARXCHL.m

Go to the documentation of this file.
IBARXCHL ;ALB/CLT- CERNER RXCOPAY BUILD THE DFT-P03 MESSAGE ; 08 Mar 2021
 ;;2.0;INTEGRATED BILLING;**676,717**;21-MAR-94;Build 1
 ;
 ; Send to Cerner the IBARXC-SEND - DFT^P03 message with a transaction
 ;
EN(DFN,FT1IEN) ;MAIN ROUTINE ENTRY POINT
 N PARMS,MSG,HDR,SEG,FIELD,VALUE,WHOTO,ERROR,%,%P1,XXX,X
 N ICN,NAME,NODE0,SETID,TRANSID,STAT,RXNUM,UNITS,TCHRG,DESC,BILLED,UNBILLED,PARENT,SITENM
 ;
 D MSH,SEND
 G END
 ;
MSH ;ENTER MSG PARAMETERS AND START THR MSG BUILD
 N PARMS K ^TMP("DFT")
 S PARMS("COUNTRY")="USA"
 S PARMS("EVENT")="P03"
 S PARMS("MESSAGE TYPE")="DFT"
 S PARMS("SENDING APPLICATION")="IBARXC-SEND"
 S PARMS("RECEIVING APPLICATION")="IBARXC-RECV"
 S PARMS("VERSION")="2.3"
 S PARMS("MESSAGE STRUCTURE")="DFT_P03"
 S MSG="^TMP(DFT"
 S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
 ;
EVN ;BUILD THE EVN SEGMENT
 D SET^HLOAPI(.SEG,"EVN",0)
 D SET^HLOAPI(.SEG,"P03",1)
 D NOW^%DTC S %P1=% S VALUE=$$FMTHL7^XLFDT(%P1)
 D SET^HLOAPI(.SEG,VALUE,2)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
 ;
PID ;ADD PID SEGMENT
 D SET^HLOAPI(.SEG,"PID",0)
 D SET^HLOAPI(.SEG,"1",1)
 S ICN=$$ICN^IBARXMU(DFN)  ;set ICN
 D SET^HLOAPI(.SEG,ICN,3)
 S NAME=$P(^DPT(DFN,0),U,1)  ;set patient name
 D SET^HLOAPI(.SEG,$P(NAME,",",1),5)
 D SET^HLOAPI(.SEG,$P(NAME,",",2),5,2)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
 ;
FT1 ;INPUT FT1 DATA FOR ONE RX COPAY
 S NODE0=$G(^IBAM(354.71,FT1IEN,0))
 Q:NODE0=""
 D SET^HLOAPI(.SEG,"FT1",0)
 S SEG="FT1",SETID=1
 D SET^HLOAPI(.SEG,SETID,1)
 S TRANSID=$P(NODE0,"^",1)
 D SET^HLOAPI(.SEG,TRANSID,2)
 S %P1=$P(NODE0,"^",3) S %P1=$$FMTHL7^XLFDT(%P1)
 D SET^HLOAPI(.SEG,%P1,4)
 D SET^HLOAPI(.SEG,"T",6)
 S STAT=$P(NODE0,"^",5)
 S STAT=$S(STAT="Y":"X",STAT="P":"C",STAT="X":"X",1:"C")
 D SET^HLOAPI(.SEG,STAT,7)
 S RXNUM=$P(NODE0,"^",6)
 S UNITS=$P(NODE0,"^",7)
 S TCHRG=$P(NODE0,"^",8)
 S DESC=$P(NODE0,"^",9)
 S DESC=$$BDESC(DESC)
 S BILLED=$P(NODE0,"^",11)
 S UNBILLED=$P(NODE0,"^",12)
 D SET^HLOAPI(.SEG,DESC,10)
 D SET^HLOAPI(.SEG,RXNUM,11)
 D SET^HLOAPI(.SEG,TCHRG,12)
 D SET^HLOAPI(.SEG,BILLED,13)
 D SET^HLOAPI(.SEG,UNBILLED,14)
 D SET^HLOAPI(.SEG,UNITS,15)
 ;DETERMINE IF THERE IS A PARENT ID
 S PARENT=$P(NODE0,"^",10)
 I PARENT="" S PARENT=FT1IEN
 S PARENT=$$GET1^DIQ(354.71,PARENT_",",.01,"E")
 D SET^HLOAPI(.SEG,PARENT,17)
 S SITENM=$$FAC^IBARXMU($P(NODE0,"^",13))
 D SET^HLOAPI(.SEG,$P(SITENM,"^",2),18)
 D SET^HLOAPI(.SEG,$P(SITENM,"^",1),18,2)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
 Q
 ;
BDESC(BDESC)  ;format Brief Description
 ; Brief Description to 'Rx # - Drug Name - Units' maximum of 20 characters, remove delimeter characters
 ; Input: Brief Description from Transaction (#354.71)
 ; Output: BDN - characters '|-^~\&' replaced by ' ' in Drug Name, Drug Name shortened to less than 20 characters
 N BDP,BD1,BD2,BD3,BD2E,BDL,BDN
 ;
 I $G(BDESC)="" Q ""
 ;
 S BDP=$L(BDESC,"-")
 S BD1=$P(BDESC,"-",1)
 S BD2=$P(BDESC,"-",2,(BDP-1))
 S BD3=$P(BDESC,"-",BDP)
 ;
 S BD2E=$TR(BD2,"|-^~\&","      ")    ; extract characters from drug name
 S BDL=20-$L(BD1_"--"_BD3)            ; number of characters available for drug name
 ;
 S BDN=BD1_"-"_$E(BD2E,1,BDL)_"-"_BD3 ; max length of 20 characters by shortening drug name
 ;
 Q BDN
 ;
SEND ;SEND MESSAGE AND QUIT
 S WHOTO("RECEIVING APPLICATION")="IBARXC-RECV"
 S WHOTO("STATION NUMBER")="200CRNR"
 S WHOTO("MIDDLEWARE LINK NAME")="IBARXCVDF"
 S PARMS("SENDING APPLICATION")="IBARXC-SEND"
 S XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
 Q
END ;CLEAN UP AND QUIT
 Q