IBCIUT2 ;DSI/SLM - CLAIMSMANAGER MESSAGE UTILITIES ;21-DEC-2000
;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
MSGHDR ;build message id segment
;
K IBCIU
S IBCIU(1)=$C(28),IBCIU(2)=$C(29),IBCIU(3)=$C(30),IBCIU(4)=$C(94),IBCIU(5)=$C(39),IBCIU(6)=$C(37)
S IBCIAA="" F I=1:1:6 S IBCIAA=IBCIAA_IBCIU(I)
K IBCIHDR S IBCIHDR=IBCIAA_"CLAIM"_IBCIU(1)
;
RSEG ;build route segment
N X,X1,X2,X3,X4,Y
S IBCIHDR=IBCIHDR_IBCIU(3)_IBCIU(3)
S X=IBCIMT,X1=3,IBCIMT=$$FILL
K X D NOW^IBCIUT1 S X=Y,X1=16,IBCIMDT=$$FILL
S X="",X1=20,IBCIMCID=$$FILL,IBCIMP="H"
S IBCIUID="DVAUSER",X=IBCIUID,X1=10,IBCIUID=$$FILL
S IBCISAP="VISTA",X=IBCISAP,X1=20,IBCISAP=$$FILL
S IBCIRAP="CLAIMS MANAGER",X=IBCIRAP,X1=20,IBCIRAP=$$FILL
S IBCISI="",X=IBCISI,X1=30,X3=".",IBCISI=$$FILL K X3
;
S IBCIHDR=IBCIHDR_IBCIMT_IBCIMDT_IBCIMCID_IBCIMP_IBCIUID
S IBCIHDR=IBCIHDR_IBCIU(3)_IBCISAP_IBCIU(3)_IBCIRAP
S IBCIHDR=IBCIHDR_IBCIU(3)_IBCISI_IBCIU(1)
;
Q
FILL() ;pad x with characters
;
;Input variables
; X = input value in non-fixed format
; X1 = desired length of the output (default is 80 if undefined)
; X2 = justify 'R' or 'L' (if undefined or not [ R or L, default is 'L')
; X3 = character you want x padded with (default is " ")
; X4 = truncate flag - if [ 'T' and x>x1 it will be truncated (default is 'T')
;
;Output variable
; Y
;
S Y=""
Q:'$D(X) Y
;
;initialize variables for fill
;
I '$D(X1) S X1=80
I X1<1 S X1=80
I '$D(X2) S X2="L"
I "RL"'[X2 S X2="L"
I X2["R"&(X2["L") S X2="L"
I '$D(X3) S X3=" "
I X3']"" S X3=" "
I '$D(X4) S X4="T"
;
I X4["T"&($L(X)>X1) S Y=$E(X,1,X1) Q Y
;
S Y="",$P(Y,X3,X1+1)="",Y=$E(Y,1,X1-$L(X))
I X2["R" S Y=Y_X
I X2["L" S Y=X_Y
Q Y
;
;asnd(ibifn) comments
;Input Variable
; ibifn
;Output Variable
; y = 1 if successful, = 0 if not.
ASND(IBIFN) ;auto send to ClaimsManager
N IBCIY S IBCIY=0,IBCIERR="" K PROBLEM
Q:'$D(IBIFN) IBCIY
;change status in 351.9
I IBCISNT'=3 D
.S IBCIST=$S(IBCISNT=6:8,IBCISNT=5:5,IBCISNT=4:9,1:2)
.D ST^IBCIUT1(IBCIST)
;
D UPDT^IBCIADD1 ;update 351.9 for all cases
;
I IBCISNT<3 D ;a normal claim that has not been authorized
.D EN^IBCIMSG,SEND
.I '$G(PROBLEM) S IBCIY=1 D
..I $P(^IBA(351.9,IBIFN,0),U,15)'=1 D ;set received by cm to yes
...S DIE="^IBA(351.9,",DA=IBIFN,DR=".15///1" D ^DIE K DIE,DA,DR
..I $P($G(^IBA(351.9,IBIFN,2,0)),U,4) D DCOM^IBCIUT4(IBIFN)
..I $$CKNER^IBCIUT1() D Q ;if no errors then...
...S (IBCISTAT,IBCIST)=3 D ST^IBCIUT1(IBCIST) ;update status=3
...D DELTI^IBCIUT4 ;delete temp info when passed w/o errors
...D DELER^IBCIUT4 ;delete error information too
...D DASN^IBCIUT5(IBIFN) ;remove the assigned to person
...Q
..D Z1AR^IBCIUT4 ;errors found then..
..S (IBCISTAT,IBCIST)=4 D ST^IBCIUT1(IBCIST)
..I IBCISNT=2 D COMMENT^IBCIUT7(IBIFN,4) ; log a comment in auto-send
..Q ; mode when errors are found
.I $G(PROBLEM) S IBCIERR=$$P1^IBCIUT4(PROBLEM) D ;comm errors
..S (IBCISTAT,IBCIST)=6 D ST^IBCIUT1(IBCIST) Q
;
I IBCISNT=3 D ;test send
.D EN^IBCIMSG,SEND
.I '$G(PROBLEM) S IBCIY=1 D
..I $$CKNER^IBCIUT1() S IBCISTAT=3 Q ;no errors...
..D Z1AR^IBCIUT4 S IBCISTAT=4 Q ;error(s) found
.I $G(PROBLEM) S IBCIERR=$$P1^IBCIUT4(PROBLEM),IBCISTAT=6 Q ;comm errors
.D TST ;put in tmp global
;
I IBCISNT=4!(IBCISNT=5) D ;canceled, overridden
.D EN^IBCIMSG,SEND
.I '$G(PROBLEM) S IBCIY=1 D
..S IBCISTAT=$$STAT^IBCIUT1(IBIFN)
..D DELTI^IBCIUT4 ;delete temp information
..D DASN^IBCIUT5(IBIFN) ;remove the assigned to person
..I IBCISNT=4 D DELER^IBCIUT4 ;delete errors
.I $G(PROBLEM) D ;comm error
..S (IBCISTAT,IBCIST)=$S(IBCISNT=5:11,IBCISNT=4:10,1:6)
..D ST^IBCIUT1(IBCIST)
..S IBCIERR=$$P1^IBCIUT4(PROBLEM)
;
I IBCISNT=6 D ;historical
.S IBCISNT=1 D EN^IBCIMSG,SEND ;send first as a normal claim
.I '$G(PROBLEM) D Q
..I '$$CKNER^IBCIUT1() D Z1AR^IBCIUT4 ;store them
..H 2 ; pause between sendings to CM
..S IBCISNT=6 D EN^IBCIMSG,SEND ;reset ibcisnt to 6 and send again
..I '$G(PROBLEM) S IBCIY=1 D Q
...S (IBCISTAT,IBCIST)=8 D ST^IBCIUT1(IBCIST)
...D DELTI^IBCIUT4 ; remove the temp nodes
...Q
..I $G(PROBLEM) D Q ;comm error on second send
...S (IBCISTAT,IBCIST)=6 D ST^IBCIUT1(IBCIST)
...S IBCIERR=$$P1^IBCIUT4(PROBLEM)
.I $G(PROBLEM) D Q ;comm error on first send
..S (IBCISTAT,IBCIST)=6 D ST^IBCIUT1(IBCIST)
..S IBCIERR=$$P1^IBCIUT4(PROBLEM)
..S IBCISNT=6
;
; Add new send type - esg - 1/3/2002
I IBCISNT=7 D ; delete lines from a UB bill on CM
. D EN^IBCIMSG,SEND
. S IBCISTAT=""
. I '$G(PROBLEM) S IBCIY=1
. I $G(PROBLEM) S IBCIERR=$$P1^IBCIUT4(PROBLEM)
. Q
;
I '$G(IBCIERR) S IBCIERR=""
Q IBCIY
;
WRT ;write the message to io
;
N I,J,ICD0,LITMS,MOD,TOTMOD
S IBCICC=0,IBCIOS=^%ZOSF("OS") D MSGHDR W IBCIHDR
S FLUSH=$S(IBCIOS["MSM":"#",IBCIOS["OpenM":"!",1:"!")
S IBCICC=IBCICC+$L(IBCIHDR) D ^IBCIUDF
;
; Data elements in the Header Segment
F I=1:1:19 D
.S IBCICC=IBCICC+$L(^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,I))
.I IBCICC>200 W @FLUSH S IBCICC=0
.W ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,I)
;
; Determine the # of line items. Write the data elements in the
; Line Segments (ExtLineID field through Units field)
;
S LITMS=$P($G(^IBA(351.9,IBIFN,5,0)),U,4)
I LITMS W IBCIU(1) F J=1:1:LITMS D
.F I=20:1:52 D
..S IBCICC=IBCICC+$L(^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,J,I))
..I IBCICC>200 W @FLUSH S IBCICC=0
..W ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,J,I)
.;
.W IBCIU(3) ; field delimiter between Units and ICDCode
.;
.; icd codes - was node 53, now just an array
.; Repeating Field
.F I=1:1:$P($G(^TMP("IBCIMSG",$J,IBIFN,"ICD",J,0)),U,2) D
..S IBCICC=IBCICC+$L(^TMP("IBCIMSG",$J,IBIFN,"ICD",J,I))
..I IBCICC>200 W @FLUSH S IBCICC=0
..W ^TMP("IBCIMSG",$J,IBIFN,"ICD",J,I)
..I I'=$P(^TMP("IBCIMSG",$J,IBIFN,"ICD",J,0),U,2) W IBCIU(4)
.;
.W IBCIU(3) ; field delimiter between ICDCode and Modifier
.;
.; cpt code node 54 multiple
.; CPT Modifier(s). Repeating Field
.S TOTMOD=$P(^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,J,54,0),U,1)
.F I=1:1:TOTMOD D
..S MOD=^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,J,54,I)
..S IBCICC=IBCICC+$L(MOD)
..I IBCICC>200 W @FLUSH S IBCICC=0
..W MOD
..I I'=TOTMOD W IBCIU(4)
.;
.W IBCIU(3) ; field delimiter between Modifier and UDF#1
.;
.; insert the user defined fields, 2 extra field delimiters, and
.; a line segment repetition delimiter if we're not done
.;
.F I=1:1:25 W IBCIUDF(I),IBCIU(3)
.W IBCIU(3),IBCIU(3)
.I J'=LITMS W IBCIU(2)
;
D CLEAN1
Q
;
SEND ;open the tcp/ip port and send msg then read response
I '$$OPENUSE^IBCIUT5 S PROBLEM=99 Q
W $C(1) D WRT W $C(3),@FLUSH
D READ^IBCIUT3(.IBCIZ,.PROBLEM,IBCISOCK)
KILL FLUSH,IBCICC,IBCIOS,IBCISOCK
Q
;
TST ;if test send, put errors in tmp global
N IBCIDA,IBCIDA1,IBCICNT K ^TMP("IBCITST",$J) S IBCICNT=1
S IBCIDA=0 F S IBCIDA=$O(IBCIZ1(IBCIDA)) Q:'IBCIDA D
.S IBCIDA1=0 S ^TMP("IBCITST",$J,IBCICNT,IBCIDA1)=IBCIZ1(IBCIDA,IBCIDA1)
.F S IBCIDA1=$O(IBCIZ1(IBCIDA,IBCIDA1)) Q:'IBCIDA1 D
..S ^TMP("IBCITST",$J,IBCICNT,1,IBCIDA1,0)=IBCIZ1(IBCIDA,IBCIDA1)
.S IBCICNT=IBCICNT+1
Q
;
CLEAN1 ; clean up the variables
K ^TMP("IBCIMSG",$J),IBCIU,IBCICLNP,IBCIUDF
CLEAN ;
K ^TMP("IBXSAVE",$J)
K X,Y,N1,D0,DA,DIC,DIE,DR,I,II,J,%,CT
K IBCIAA,IBCIAPC,IBCIAPID,IBCIBDPS,IBCIBPDE
K IBCIBPDI,IBCIBPFI,IBCIBPID,IBCIBPLA,IBCIBPMI,IBCIBPSP
K IBCIBPTI,IBCIBPUP,IBCICL,IBCICPT,IBCIDE,IBCIDFN,IBCIBDOS
K IBCIDOB,IBCIEB,IBCIEBID,IBCIEDOS,IBCIET,IBCIHDR
K IBCILSEG,IBCILSTA,IBCIMCID,IBCIMDT,IBCIMP
K IBCIOGID,IBCIOID,IBCIPAC,IBCIPID,IBCIPOS,IBCIPPID
K IBCIPTFI,IBCIPTLA,IBCIPTMI,IBCIRAP,IBCIRPDE,IBCIRPDI,IBCIRPFI
K IBCIRPID,IBCIRPLA,IBCIRPMI,IBCIRPSP,IBCIRPTI,IBCIRPUP,IBCISAMT
K IBCISAP,IBCISEX,IBCISI,IBCISPAI,IBCISPC,IBCISPDE,IBCISPDI
K IBCISPFI,IBCISPID,IBCISPLA,IBCISPMI,IBCISPSP,IBCISPTI,IBCISPUP
K IBCIST,IBCITC,IBCITOS,IBCIUID,IBCIUNIT,IBCIXLID,IBX,IBY
K IENS,NODE3,NODE4,NODE50,NODE51,NODE52,RCD1,CPD1
K IBCIZ,IBCIZ1,IBXARRAY,IBXARRY,IBXDAT1,IBXDATA,IBXERR
K IBCITSI,X1,X2,X3,X4,IBCILSI,CTR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCIUT2 8346 printed Apr 09, 2024@21:18:12 Page 2
IBCIUT2 ;DSI/SLM - CLAIMSMANAGER MESSAGE UTILITIES ;21-DEC-2000
+1 ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
MSGHDR ;build message id segment
+1 ;
+2 KILL IBCIU
+3 SET IBCIU(1)=$CHAR(28)
SET IBCIU(2)=$CHAR(29)
SET IBCIU(3)=$CHAR(30)
SET IBCIU(4)=$CHAR(94)
SET IBCIU(5)=$CHAR(39)
SET IBCIU(6)=$CHAR(37)
+4 SET IBCIAA=""
FOR I=1:1:6
SET IBCIAA=IBCIAA_IBCIU(I)
+5 KILL IBCIHDR
SET IBCIHDR=IBCIAA_"CLAIM"_IBCIU(1)
+6 ;
RSEG ;build route segment
+1 NEW X,X1,X2,X3,X4,Y
+2 SET IBCIHDR=IBCIHDR_IBCIU(3)_IBCIU(3)
+3 SET X=IBCIMT
SET X1=3
SET IBCIMT=$$FILL
+4 KILL X
DO NOW^IBCIUT1
SET X=Y
SET X1=16
SET IBCIMDT=$$FILL
+5 SET X=""
SET X1=20
SET IBCIMCID=$$FILL
SET IBCIMP="H"
+6 SET IBCIUID="DVAUSER"
SET X=IBCIUID
SET X1=10
SET IBCIUID=$$FILL
+7 SET IBCISAP="VISTA"
SET X=IBCISAP
SET X1=20
SET IBCISAP=$$FILL
+8 SET IBCIRAP="CLAIMS MANAGER"
SET X=IBCIRAP
SET X1=20
SET IBCIRAP=$$FILL
+9 SET IBCISI=""
SET X=IBCISI
SET X1=30
SET X3="."
SET IBCISI=$$FILL
KILL X3
+10 ;
+11 SET IBCIHDR=IBCIHDR_IBCIMT_IBCIMDT_IBCIMCID_IBCIMP_IBCIUID
+12 SET IBCIHDR=IBCIHDR_IBCIU(3)_IBCISAP_IBCIU(3)_IBCIRAP
+13 SET IBCIHDR=IBCIHDR_IBCIU(3)_IBCISI_IBCIU(1)
+14 ;
+15 QUIT
FILL() ;pad x with characters
+1 ;
+2 ;Input variables
+3 ; X = input value in non-fixed format
+4 ; X1 = desired length of the output (default is 80 if undefined)
+5 ; X2 = justify 'R' or 'L' (if undefined or not [ R or L, default is 'L')
+6 ; X3 = character you want x padded with (default is " ")
+7 ; X4 = truncate flag - if [ 'T' and x>x1 it will be truncated (default is 'T')
+8 ;
+9 ;Output variable
+10 ; Y
+11 ;
+12 SET Y=""
+13 if '$DATA(X)
QUIT Y
+14 ;
+15 ;initialize variables for fill
+16 ;
+17 IF '$DATA(X1)
SET X1=80
+18 IF X1<1
SET X1=80
+19 IF '$DATA(X2)
SET X2="L"
+20 IF "RL"'[X2
SET X2="L"
+21 IF X2["R"&(X2["L")
SET X2="L"
+22 IF '$DATA(X3)
SET X3=" "
+23 IF X3']""
SET X3=" "
+24 IF '$DATA(X4)
SET X4="T"
+25 ;
+26 IF X4["T"&($LENGTH(X)>X1)
SET Y=$EXTRACT(X,1,X1)
QUIT Y
+27 ;
+28 SET Y=""
SET $PIECE(Y,X3,X1+1)=""
SET Y=$EXTRACT(Y,1,X1-$LENGTH(X))
+29 IF X2["R"
SET Y=Y_X
+30 IF X2["L"
SET Y=X_Y
+31 QUIT Y
+32 ;
+33 ;asnd(ibifn) comments
+34 ;Input Variable
+35 ; ibifn
+36 ;Output Variable
+37 ; y = 1 if successful, = 0 if not.
ASND(IBIFN) ;auto send to ClaimsManager
+1 NEW IBCIY
SET IBCIY=0
SET IBCIERR=""
KILL PROBLEM
+2 if '$DATA(IBIFN)
QUIT IBCIY
+3 ;change status in 351.9
+4 IF IBCISNT'=3
Begin DoDot:1
+5 SET IBCIST=$SELECT(IBCISNT=6:8,IBCISNT=5:5,IBCISNT=4:9,1:2)
+6 DO ST^IBCIUT1(IBCIST)
End DoDot:1
+7 ;
+8 ;update 351.9 for all cases
DO UPDT^IBCIADD1
+9 ;
+10 ;a normal claim that has not been authorized
IF IBCISNT<3
Begin DoDot:1
+11 DO EN^IBCIMSG
DO SEND
+12 IF '$GET(PROBLEM)
SET IBCIY=1
Begin DoDot:2
+13 ;set received by cm to yes
IF $PIECE(^IBA(351.9,IBIFN,0),U,15)'=1
Begin DoDot:3
+14 SET DIE="^IBA(351.9,"
SET DA=IBIFN
SET DR=".15///1"
DO ^DIE
KILL DIE,DA,DR
End DoDot:3
+15 IF $PIECE($GET(^IBA(351.9,IBIFN,2,0)),U,4)
DO DCOM^IBCIUT4(IBIFN)
+16 ;if no errors then...
IF $$CKNER^IBCIUT1()
Begin DoDot:3
+17 ;update status=3
SET (IBCISTAT,IBCIST)=3
DO ST^IBCIUT1(IBCIST)
+18 ;delete temp info when passed w/o errors
DO DELTI^IBCIUT4
+19 ;delete error information too
DO DELER^IBCIUT4
+20 ;remove the assigned to person
DO DASN^IBCIUT5(IBIFN)
+21 QUIT
End DoDot:3
QUIT
+22 ;errors found then..
DO Z1AR^IBCIUT4
+23 SET (IBCISTAT,IBCIST)=4
DO ST^IBCIUT1(IBCIST)
+24 ; log a comment in auto-send
IF IBCISNT=2
DO COMMENT^IBCIUT7(IBIFN,4)
+25 ; mode when errors are found
QUIT
End DoDot:2
+26 ;comm errors
IF $GET(PROBLEM)
SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
Begin DoDot:2
+27 SET (IBCISTAT,IBCIST)=6
DO ST^IBCIUT1(IBCIST)
QUIT
End DoDot:2
End DoDot:1
+28 ;
+29 ;test send
IF IBCISNT=3
Begin DoDot:1
+30 DO EN^IBCIMSG
DO SEND
+31 IF '$GET(PROBLEM)
SET IBCIY=1
Begin DoDot:2
+32 ;no errors...
IF $$CKNER^IBCIUT1()
SET IBCISTAT=3
QUIT
+33 ;error(s) found
DO Z1AR^IBCIUT4
SET IBCISTAT=4
QUIT
End DoDot:2
+34 ;comm errors
IF $GET(PROBLEM)
SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
SET IBCISTAT=6
QUIT
+35 ;put in tmp global
DO TST
End DoDot:1
+36 ;
+37 ;canceled, overridden
IF IBCISNT=4!(IBCISNT=5)
Begin DoDot:1
+38 DO EN^IBCIMSG
DO SEND
+39 IF '$GET(PROBLEM)
SET IBCIY=1
Begin DoDot:2
+40 SET IBCISTAT=$$STAT^IBCIUT1(IBIFN)
+41 ;delete temp information
DO DELTI^IBCIUT4
+42 ;remove the assigned to person
DO DASN^IBCIUT5(IBIFN)
+43 ;delete errors
IF IBCISNT=4
DO DELER^IBCIUT4
End DoDot:2
+44 ;comm error
IF $GET(PROBLEM)
Begin DoDot:2
+45 SET (IBCISTAT,IBCIST)=$SELECT(IBCISNT=5:11,IBCISNT=4:10,1:6)
+46 DO ST^IBCIUT1(IBCIST)
+47 SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
End DoDot:2
End DoDot:1
+48 ;
+49 ;historical
IF IBCISNT=6
Begin DoDot:1
+50 ;send first as a normal claim
SET IBCISNT=1
DO EN^IBCIMSG
DO SEND
+51 IF '$GET(PROBLEM)
Begin DoDot:2
+52 ;store them
IF '$$CKNER^IBCIUT1()
DO Z1AR^IBCIUT4
+53 ; pause between sendings to CM
HANG 2
+54 ;reset ibcisnt to 6 and send again
SET IBCISNT=6
DO EN^IBCIMSG
DO SEND
+55 IF '$GET(PROBLEM)
SET IBCIY=1
Begin DoDot:3
+56 SET (IBCISTAT,IBCIST)=8
DO ST^IBCIUT1(IBCIST)
+57 ; remove the temp nodes
DO DELTI^IBCIUT4
+58 QUIT
End DoDot:3
QUIT
+59 ;comm error on second send
IF $GET(PROBLEM)
Begin DoDot:3
+60 SET (IBCISTAT,IBCIST)=6
DO ST^IBCIUT1(IBCIST)
+61 SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
End DoDot:3
QUIT
End DoDot:2
QUIT
+62 ;comm error on first send
IF $GET(PROBLEM)
Begin DoDot:2
+63 SET (IBCISTAT,IBCIST)=6
DO ST^IBCIUT1(IBCIST)
+64 SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
+65 SET IBCISNT=6
End DoDot:2
QUIT
End DoDot:1
+66 ;
+67 ; Add new send type - esg - 1/3/2002
+68 ; delete lines from a UB bill on CM
IF IBCISNT=7
Begin DoDot:1
+69 DO EN^IBCIMSG
DO SEND
+70 SET IBCISTAT=""
+71 IF '$GET(PROBLEM)
SET IBCIY=1
+72 IF $GET(PROBLEM)
SET IBCIERR=$$P1^IBCIUT4(PROBLEM)
+73 QUIT
End DoDot:1
+74 ;
+75 IF '$GET(IBCIERR)
SET IBCIERR=""
+76 QUIT IBCIY
+77 ;
WRT ;write the message to io
+1 ;
+2 NEW I,J,ICD0,LITMS,MOD,TOTMOD
+3 SET IBCICC=0
SET IBCIOS=^%ZOSF("OS")
DO MSGHDR
WRITE IBCIHDR
+4 SET FLUSH=$SELECT(IBCIOS["MSM":"#",IBCIOS["OpenM":"!",1:"!")
+5 SET IBCICC=IBCICC+$LENGTH(IBCIHDR)
DO ^IBCIUDF
+6 ;
+7 ; Data elements in the Header Segment
+8 FOR I=1:1:19
Begin DoDot:1
+9 SET IBCICC=IBCICC+$LENGTH(^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,I))
+10 IF IBCICC>200
WRITE @FLUSH
SET IBCICC=0
+11 WRITE ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,I)
End DoDot:1
+12 ;
+13 ; Determine the # of line items. Write the data elements in the
+14 ; Line Segments (ExtLineID field through Units field)
+15 ;
+16 SET LITMS=$PIECE($GET(^IBA(351.9,IBIFN,5,0)),U,4)
+17 IF LITMS
WRITE IBCIU(1)
FOR J=1:1:LITMS
Begin DoDot:1
+18 FOR I=20:1:52
Begin DoDot:2
+19 SET IBCICC=IBCICC+$LENGTH(^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,J,I))
+20 IF IBCICC>200
WRITE @FLUSH
SET IBCICC=0
+21 WRITE ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,J,I)
End DoDot:2
+22 ;
+23 ; field delimiter between Units and ICDCode
WRITE IBCIU(3)
+24 ;
+25 ; icd codes - was node 53, now just an array
+26 ; Repeating Field
+27 FOR I=1:1:$PIECE($GET(^TMP("IBCIMSG",$JOB,IBIFN,"ICD",J,0)),U,2)
Begin DoDot:2
+28 SET IBCICC=IBCICC+$LENGTH(^TMP("IBCIMSG",$JOB,IBIFN,"ICD",J,I))
+29 IF IBCICC>200
WRITE @FLUSH
SET IBCICC=0
+30 WRITE ^TMP("IBCIMSG",$JOB,IBIFN,"ICD",J,I)
+31 IF I'=$PIECE(^TMP("IBCIMSG",$JOB,IBIFN,"ICD",J,0),U,2)
WRITE IBCIU(4)
End DoDot:2
+32 ;
+33 ; field delimiter between ICDCode and Modifier
WRITE IBCIU(3)
+34 ;
+35 ; cpt code node 54 multiple
+36 ; CPT Modifier(s). Repeating Field
+37 SET TOTMOD=$PIECE(^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,J,54,0),U,1)
+38 FOR I=1:1:TOTMOD
Begin DoDot:2
+39 SET MOD=^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,J,54,I)
+40 SET IBCICC=IBCICC+$LENGTH(MOD)
+41 IF IBCICC>200
WRITE @FLUSH
SET IBCICC=0
+42 WRITE MOD
+43 IF I'=TOTMOD
WRITE IBCIU(4)
End DoDot:2
+44 ;
+45 ; field delimiter between Modifier and UDF#1
WRITE IBCIU(3)
+46 ;
+47 ; insert the user defined fields, 2 extra field delimiters, and
+48 ; a line segment repetition delimiter if we're not done
+49 ;
+50 FOR I=1:1:25
WRITE IBCIUDF(I),IBCIU(3)
+51 WRITE IBCIU(3),IBCIU(3)
+52 IF J'=LITMS
WRITE IBCIU(2)
End DoDot:1
+53 ;
+54 DO CLEAN1
+55 QUIT
+56 ;
SEND ;open the tcp/ip port and send msg then read response
+1 IF '$$OPENUSE^IBCIUT5
SET PROBLEM=99
QUIT
+2 WRITE $CHAR(1)
DO WRT
WRITE $CHAR(3),@FLUSH
+3 DO READ^IBCIUT3(.IBCIZ,.PROBLEM,IBCISOCK)
+4 KILL FLUSH,IBCICC,IBCIOS,IBCISOCK
+5 QUIT
+6 ;
TST ;if test send, put errors in tmp global
+1 NEW IBCIDA,IBCIDA1,IBCICNT
KILL ^TMP("IBCITST",$JOB)
SET IBCICNT=1
+2 SET IBCIDA=0
FOR
SET IBCIDA=$ORDER(IBCIZ1(IBCIDA))
if 'IBCIDA
QUIT
Begin DoDot:1
+3 SET IBCIDA1=0
SET ^TMP("IBCITST",$JOB,IBCICNT,IBCIDA1)=IBCIZ1(IBCIDA,IBCIDA1)
+4 FOR
SET IBCIDA1=$ORDER(IBCIZ1(IBCIDA,IBCIDA1))
if 'IBCIDA1
QUIT
Begin DoDot:2
+5 SET ^TMP("IBCITST",$JOB,IBCICNT,1,IBCIDA1,0)=IBCIZ1(IBCIDA,IBCIDA1)
End DoDot:2
+6 SET IBCICNT=IBCICNT+1
End DoDot:1
+7 QUIT
+8 ;
CLEAN1 ; clean up the variables
+1 KILL ^TMP("IBCIMSG",$JOB),IBCIU,IBCICLNP,IBCIUDF
CLEAN ;
+1 KILL ^TMP("IBXSAVE",$JOB)
+2 KILL X,Y,N1,D0,DA,DIC,DIE,DR,I,II,J,%,CT
+3 KILL IBCIAA,IBCIAPC,IBCIAPID,IBCIBDPS,IBCIBPDE
+4 KILL IBCIBPDI,IBCIBPFI,IBCIBPID,IBCIBPLA,IBCIBPMI,IBCIBPSP
+5 KILL IBCIBPTI,IBCIBPUP,IBCICL,IBCICPT,IBCIDE,IBCIDFN,IBCIBDOS
+6 KILL IBCIDOB,IBCIEB,IBCIEBID,IBCIEDOS,IBCIET,IBCIHDR
+7 KILL IBCILSEG,IBCILSTA,IBCIMCID,IBCIMDT,IBCIMP
+8 KILL IBCIOGID,IBCIOID,IBCIPAC,IBCIPID,IBCIPOS,IBCIPPID
+9 KILL IBCIPTFI,IBCIPTLA,IBCIPTMI,IBCIRAP,IBCIRPDE,IBCIRPDI,IBCIRPFI
+10 KILL IBCIRPID,IBCIRPLA,IBCIRPMI,IBCIRPSP,IBCIRPTI,IBCIRPUP,IBCISAMT
+11 KILL IBCISAP,IBCISEX,IBCISI,IBCISPAI,IBCISPC,IBCISPDE,IBCISPDI
+12 KILL IBCISPFI,IBCISPID,IBCISPLA,IBCISPMI,IBCISPSP,IBCISPTI,IBCISPUP
+13 KILL IBCIST,IBCITC,IBCITOS,IBCIUID,IBCIUNIT,IBCIXLID,IBX,IBY
+14 KILL IENS,NODE3,NODE4,NODE50,NODE51,NODE52,RCD1,CPD1
+15 KILL IBCIZ,IBCIZ1,IBXARRAY,IBXARRY,IBXDAT1,IBXDATA,IBXERR
+16 KILL IBCITSI,X1,X2,X3,X4,IBCILSI,CTR
+17 QUIT
+18 ;
