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