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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXCSH 4805 printed Sep 23, 2025@19:43:17 Page 2
IBARXCSH ;ALB/CLT-CERNER RXCOPAY SEND DSR-QO3 MESSAGE ; 19 Feb 2021
+1 ;;2.0;INTEGRATED BILLING;**676,717,726**;21-MAR-94;Build 1
+2 ;
+3 ; Build and return/send seeding of Vista data to Cerner IBARXC-QRYRESP DSR^Q03
+4 ;
EN(ICN,IBIEN,DATEQ) ;ENTRY POINT
+1 ; IBIEN - Query Request Message IEN (#778) that initiated this response
+2 ;
+3 NEW PARMS,SEG,MSG,VALUE,FIELD,QRYNUM,SERROR,SERR,NAME,ERROR,DFN,XXX,WHOTO
+4 SET DFN=$$DFN^IBARXMU(ICN)
+5 IF +DFN<0
SET SERROR="NO PATIENT FOUND WITH SUBMITTED ICN"
SET SERR=1
+6 ; Message Control ID of initiating Query
SET QRYNUM=$$MSGID^HLOPRS(IBIEN)
+7 if $GET(SERR)=""
SET SERR=0
MSH ;
+1 NEW PARMS
KILL ^TMP("DSR")
+2 SET PARMS("COUNTRY")="USA"
+3 SET PARMS("MESSAGE TYPE")="DSR"
+4 SET PARMS("EVENT")="Q03"
+5 SET PARMS("SENDING APPLICATION")="IBARXC-QRYRESP"
+6 SET PARMS("VERSION")="2.3"
+7 SET PARMS("MESSAGE STRUCTURE")="DSR_Q03"
+8 SET MSG="^TMP("_"DSR"
+9 SET X=$$NEWMSG^HLOAPI(.PARMS,.MSG,.ERROR)
MSA ;
+1 SET VALUE="MSA"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 SET VALUE="AL"
SET FIELD=1
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+3 SET VALUE=QRYNUM
SET FIELD=2
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+4 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
QRD ;
+1 SET VALUE="QRD"
SET FIELD=0
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+2 SET %P1=$$NOW^XLFDT()
SET %P1=$$FMTHL7^XLFDT(%P1)
+3 SET VALUE=%P1
SET FIELD=1
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+4 SET VALUE=1
SET FIELD=2
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+5 SET VALUE=1
SET FIELD=3
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+6 SET VALUE=QRYNUM
SET FIELD=4
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+7 SET VALUE=1
SET FIELD=7
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+8 SET NAME=$$GET1^DIQ(2,DFN_",",.01)
+9 SET VALUE=$PIECE($GET(NAME),",",1)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,1)
+10 SET VALUE=$PIECE($GET(NAME),",",2)
SET FIELD=8
DO SET^HLOAPI(.SEG,VALUE,FIELD,2)
+11 SET VALUE=ICN
SET FIELD=9
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+12 SET FIELD=11
+13 SET VALUE=$PIECE(DATEQ,"^",1)
DO SET^HLOAPI(.SEG,VALUE,FIELD,1)
+14 SET VALUE=$PIECE(DATEQ,"^",2)
DO SET^HLOAPI(.SEG,VALUE,FIELD,2)
+15 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
DSPLOOP ;LOOP THROUGH THE DSP FOR ALL OR THE LAST TRANSACTION
+1 NEW BDATE,EDATE,IBLOOP,DTY,FOUND1,IEN
+2 SET DTY=($PIECE(DATEQ,"^",2)-1700)
+3 ;BEGINNING OF DATE RANGR
SET BDATE=$EXTRACT(DTY,1,3)_"0000"
+4 ;ENDING OF DATE RANGE
SET EDATE=$EXTRACT(DTY,1,3)_"1231"
+5 IF SERR=1
GOTO DSP
+6 SET FOUND1=0
SET IBLOOP=0
SET IEN=0
+7 FOR
SET BDATE=$ORDER(^IBAM(354.71,"AD",DFN,BDATE))
if BDATE=""!(BDATE>EDATE)
QUIT
Begin DoDot:1
+8 FOR
SET IEN=$ORDER(^IBAM(354.71,"AD",DFN,BDATE,IEN))
if IEN=""
QUIT
Begin DoDot:2
+9 SET IBLOOP=IBLOOP+1
+10 DO DSP
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF 'FOUND1
SET SERROR="NO PHARMACY COPAY TRANSACTION DATA"
SET SERR=1
DO DSP
+14 GOTO END
+15 QUIT
+16 ;
DSP ;
+1 IF IBLOOP=0
SET IBLOOP=1
+2 DO SET^HLOAPI(.SEG,"DSP",0)
DO SET^HLOAPI(.SEG,IBLOOP,1)
+3 IF $GET(SERR)=1
DO ERR
GOTO END
DSP1 ;
+1 NEW NODE0,FACID,FACID1,TRANSID,TCHRG,BILLED,UNBILLED,ADATE
+2 NEW YDATE,STAT,UNITS,DESC,RXNUM,PARENT,SITENM,X
+3 SET NODE0=^IBAM(354.71,IEN,0)
+4 ;Null Unbilled issue
+5 IF $PIECE(NODE0,"^",12)=""
SET NODE0=$$NULLFIX(IEN,NODE0)
+6 SET FACID=+$$SITE^VASITE
+7 SET FACID1=$PIECE(NODE0,"^",13)
+8 if FACID1'=FACID
QUIT
+9 SET FOUND1=1
+10 DO SET^HLOAPI(.SEG,"FT1",3,1)
+11 SET TRANSID=$PIECE(NODE0,"^",1)
+12 DO SET^HLOAPI(.SEG,TRANSID,3,2)
+13 SET ADATE=$PIECE(NODE0,"^",3)
+14 SET YDATE=($EXTRACT(ADATE,1,3)+1700)_$EXTRACT(ADATE,4,7)
+15 DO SET^HLOAPI(.SEG,YDATE,3,4)
+16 DO SET^HLOAPI(.SEG,"T",3,6)
+17 SET STAT=$PIECE(NODE0,"^",5)
+18 SET STAT=$SELECT(STAT="P":"C",STAT="Y":"X",STAT="X":"X",1:"C")
+19 DO SET^HLOAPI(.SEG,STAT,3,7)
+20 SET DESC=$PIECE(NODE0,"^",9)
+21 SET DESC=$$BDESC^IBARXCHL(DESC)
+22 SET RXNUM=$PIECE(NODE0,"^",6)
+23 SET TCHRG=$PIECE(NODE0,"^",8)
+24 SET BILLED=$PIECE(NODE0,"^",11)
+25 SET UNBILLED=$PIECE(NODE0,"^",12)
+26 SET UNITS=$PIECE(NODE0,"^",7)
+27 ;NEED FACILITY IEN TO GET FACILITY NAME
+28 SET SITENM=$$FAC^IBARXMU($PIECE(NODE0,"^",13))
+29 ;FIND PARENT ID
+30 SET PARENT=$PIECE(NODE0,"^",10)
+31 IF PARENT=""
SET PARENT=IEN
+32 SET PARENT=$$GET1^DIQ(354.71,PARENT_",",.01,"E")
+33 SET FIELD=3
+34 DO SET^HLOAPI(.SEG,DESC,FIELD,10)
+35 DO SET^HLOAPI(.SEG,RXNUM,FIELD,11)
+36 DO SET^HLOAPI(.SEG,+TCHRG,FIELD,12)
+37 DO SET^HLOAPI(.SEG,+BILLED,FIELD,13)
+38 DO SET^HLOAPI(.SEG,+UNBILLED,FIELD,14)
+39 DO SET^HLOAPI(.SEG,UNITS,FIELD,15)
+40 DO SET^HLOAPI(.SEG,PARENT,FIELD,17)
+41 DO SET^HLOAPI(.SEG,$PIECE(SITENM,"^",2),FIELD,18)
+42 DO SET^HLOAPI(.SEG,$PIECE(SITENM,"^",1),FIELD,18,2)
+43 SET VALUE=""
SET FIELD=5
DO SET^HLOAPI(.SEG,VALUE,FIELD)
+44 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+45 QUIT
+46 ;
NULLFIX(IEN,NODE0) ;The IBEDIT function will all Null values to be passed in Unbilled value
+1 ;set NODE0 piece 12 to 0, then set field .12 to 0 to ensure proper data transmission
+2 NEW DIEN
+3 IF $PIECE(NODE0,"^",12)=""
SET $PIECE(NODE0,"^",12)=0
+4 ;Now set data field .12 in 354.71 to 0
+5 SET DIEN=IEN_","
+6 SET IBFDA(354.71,DIEN,.12)=0
+7 DO FILE^DIE(,"IBFDA","IBERR")
+8 QUIT NODE0
+9 ;
END ;
+1 SET WHOTO("RECEIVING APPLICATION")="IBARXC-QRY"
+2 SET WHOTO("STATION NUMBER")="200CRNR"
+3 SET WHOTO("MIDDLEWARE LINK NAME")="IBARXCVDF"
+4 SET XXX=$$SENDONE^HLOAPI1(.MSG,.PARMS,.WHOTO,.ERROR)
+5 QUIT
+6 ;
ERR ;ERROR PROCESSING
+1 NEW BLANK,VALUE,I
+2 SET BLANK=""
FOR I=1:1:18
DO SET^HLOAPI(.SEG,BLANK,3,I)
+3 SET VALUE=SERROR
DO SET^HLOAPI(.SEG,VALUE,5)
+4 SET X=$$ADDSEG^HLOAPI(.MSG,.SEG,.ERROR)
+5 QUIT
