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

IBARXCSH.m

Go to the documentation of this file.
IBARXCSH ;ALB/CLT-CERNER RXCOPAY SEND DSR-QO3 MESSAGE ; 19 Feb 2021
 ;;2.0;INTEGRATED BILLING;**676,717,726**;21-MAR-94;Build 1
 ;
 ; Build and return/send seeding of Vista data to Cerner IBARXC-QRYRESP DSR^Q03 
 ;
EN(ICN,IBIEN,DATEQ) ;ENTRY POINT
 ; IBIEN - Query Request Message IEN (#778) that initiated this response 
 ;
 N PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,DFN,XXX,WHOTO
 S DFN=$$DFN^IBARXMU(ICN)
 I +DFN<0 S SERROR="NO PATIENT FOUND WITH SUBMITTED ICN",SERR=1
 S QRYNUM=$$MSGID^HLOPRS(IBIEN)  ; Message Control ID of initiating Query 
 S:$G(SERR)="" SERR=0
MSH ;
 N PARMS K ^TMP("DSR")
 S PARMS("COUNTRY")="USA"
 S PARMS("MESSAGE TYPE")="DSR"
 S PARMS("EVENT")="Q03"
 S PARMS("SENDING APPLICATION")="IBARXC-QRYRESP"
 S PARMS("VERSION")="2.3"
 S PARMS("MESSAGE STRUCTURE")="DSR_Q03"
 S MSG="^TMP("_"DSR"
 S X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSA ;
 S VALUE="MSA",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE="AL",FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE=QRYNUM,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
QRD ;
 S VALUE="QRD",FIELD=0 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S %P1=$$NOW^XLFDT() S %P1=$$FMTHL7^XLFDT(%P1)
 S VALUE=%P1,FIELD=1 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE=1,FIELD=2 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE=1,FIELD=3 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE=QRYNUM,FIELD=4 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S VALUE=1,FIELD=7 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S NAME=$$GET1^DIQ(2,DFN_",",.01)
 S VALUE=$P($G(NAME),",",1),FIELD=8 D SET^HLOAPI(.SEG,VALUE,FIELD,1)
 S VALUE=$P($G(NAME),",",2),FIELD=8 D SET^HLOAPI(.SEG,VALUE,FIELD,2)
 S VALUE=ICN,FIELD=9 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S FIELD=11
 S VALUE=$P(DATEQ,"^",1) D SET^HLOAPI(.SEG,VALUE,FIELD,1)
 S VALUE=$P(DATEQ,"^",2) D SET^HLOAPI(.SEG,VALUE,FIELD,2)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
DSPLOOP ;LOOP THROUGH THE DSP FOR ALL OR THE LAST TRANSACTION
 N BDATE,EDATE,IBLOOP,DTY,FOUND1,IEN
 S DTY=($P(DATEQ,"^",2)-1700)
 S BDATE=$E(DTY,1,3)_"0000"  ;BEGINNING OF DATE RANGR
 S EDATE=$E(DTY,1,3)_"1231"  ;ENDING OF DATE RANGE
 I SERR=1 G DSP
 S FOUND1=0,IBLOOP=0,IEN=0
 F  S BDATE=$O(^IBAM(354.71,"AD",DFN,BDATE)) Q:BDATE=""!(BDATE>EDATE)  D
 . F  S IEN=$O(^IBAM(354.71,"AD",DFN,BDATE,IEN)) Q:IEN=""  D
 . . S IBLOOP=IBLOOP+1
 . . D DSP
 . . Q
 . Q
 I 'FOUND1 S SERROR="NO PHARMACY COPAY TRANSACTION DATA",SERR=1 D DSP
 G END
 Q
 ;
DSP ;
 I IBLOOP=0 S IBLOOP=1
 D SET^HLOAPI(.SEG,"DSP",0),SET^HLOAPI(.SEG,IBLOOP,1)
 I $G(SERR)=1 D ERR G END
DSP1 ;
 N NODE0,FACID,FACID1,TRANSID,TCHRG,BILLED,UNBILLED,ADATE
 N YDATE,STAT,UNITS,DESC,RXNUM,PARENT,SITENM,X
 S NODE0=^IBAM(354.71,IEN,0)
 ;Null Unbilled issue
 I $P(NODE0,"^",12)="" S NODE0=$$NULLFIX(IEN,NODE0)
 S FACID=+$$SITE^VASITE
 S FACID1=$P(NODE0,"^",13)
 Q:FACID1'=FACID
 S FOUND1=1
 D SET^HLOAPI(.SEG,"FT1",3,1)
 S TRANSID=$P(NODE0,"^",1)
 D SET^HLOAPI(.SEG,TRANSID,3,2)
 S ADATE=$P(NODE0,"^",3)
 S YDATE=($E(ADATE,1,3)+1700)_$E(ADATE,4,7)
 D SET^HLOAPI(.SEG,YDATE,3,4)
 D SET^HLOAPI(.SEG,"T",3,6)
 S STAT=$P(NODE0,"^",5)
 S STAT=$S(STAT="P":"C",STAT="Y":"X",STAT="X":"X",1:"C")
 D SET^HLOAPI(.SEG,STAT,3,7)
 S DESC=$P(NODE0,"^",9)
 S DESC=$$BDESC^IBARXCHL(DESC)
 S RXNUM=$P(NODE0,"^",6)
 S TCHRG=$P(NODE0,"^",8)
 S BILLED=$P(NODE0,"^",11)
 S UNBILLED=$P(NODE0,"^",12)
 S UNITS=$P(NODE0,"^",7)
 ;NEED FACILITY IEN TO GET FACILITY NAME
 S SITENM=$$FAC^IBARXMU($P(NODE0,"^",13))
 ;FIND PARENT ID
 S PARENT=$P(NODE0,"^",10)
 I PARENT="" S PARENT=IEN
 S PARENT=$$GET1^DIQ(354.71,PARENT_",",.01,"E")
 S FIELD=3
 D SET^HLOAPI(.SEG,DESC,FIELD,10)
 D SET^HLOAPI(.SEG,RXNUM,FIELD,11)
 D SET^HLOAPI(.SEG,+TCHRG,FIELD,12)
 D SET^HLOAPI(.SEG,+BILLED,FIELD,13)
 D SET^HLOAPI(.SEG,+UNBILLED,FIELD,14)
 D SET^HLOAPI(.SEG,UNITS,FIELD,15)
 D SET^HLOAPI(.SEG,PARENT,FIELD,17)
 D SET^HLOAPI(.SEG,$P(SITENM,"^",2),FIELD,18)
 D SET^HLOAPI(.SEG,$P(SITENM,"^",1),FIELD,18,2)
 S VALUE="",FIELD=5 D SET^HLOAPI(.SEG,VALUE,FIELD)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
 Q
 ;
NULLFIX(IEN,NODE0)  ;The IBEDIT function will all Null values to be passed in Unbilled value
 ;set NODE0 piece 12 to 0, then set field .12 to 0 to ensure proper data transmission
 N DIEN
 I $P(NODE0,"^",12)="" S $P(NODE0,"^",12)=0
 ;Now set data field .12 in 354.71 to 0
 S DIEN=IEN_","
 S IBFDA(354.71,DIEN,.12)=0
 D FILE^DIE(,"IBFDA","IBERR")
 Q NODE0
 ;
END ;
 S WHOTO("RECEIVING APPLICATION")="IBARXC-QRY"
 S WHOTO("STATION NUMBER")="200CRNR"
 S WHOTO("MIDDLEWARE LINK NAME")="IBARXCVDF"
 S XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
 Q
 ;
ERR ;ERROR PROCESSING
 N BLANK,VALUE,I
 S BLANK="" F I=1:1:18 D SET^HLOAPI(.SEG,BLANK,3,I)
 S VALUE=SERROR D SET^HLOAPI(.SEG,VALUE,5)
 S X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
 Q