IBCIMSG ;DSI/SLM - BUILD MESSAGE FOR CLAIMSMANAGER ;12-JAN-2001
;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ;
KILL ^TMP("IBCIMSG",$J) ; kill scratch global before building it
Q:'$D(IBIFN)
D INIT
Q
;
INIT ;initialize variables for building the message
S NODE3=$G(^IBA(351.9,IBIFN,3)),NODE4=$G(^IBA(351.9,IBIFN,4))
S X=NODE3 D TCK^IBCIUT4() S NODE3=X
S X=NODE4 D TCK^IBCIUT4() S NODE4=X
I '$D(IBCISNT) S IBCISNT=1
S IBCICL=$P(^DGCR(399,IBIFN,0),U),IBCICLNP=IBCICL
S X=IBCICL,X1=25,IBCICL=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,2)=IBCICL
S IBCIEBID=$$NOW^XLFDT,X=IBCIEBID D NOW^IBCIUT1 S IBCIEBID=Y K Y
S X=IBCIEBID,X1=25,IBCIEBID=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,1)=IBCIEBID
S IBCIPID=$P(NODE3,U,1),X=IBCIPID,X1=20,IBCIPID=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,3)=IBCIPID
S IBCIAPID="",X=$G(IBCIAPID),X1=20,IBCIAPID=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,4)=IBCIAPID
S IBCIPTLA=$P(NODE3,U,2),X=IBCIPTLA,X1=40,IBCIPTLA=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,5)=IBCIPTLA
S IBCIPTMI=$P(NODE3,U,3),X=IBCIPTMI,X1=20,IBCIPTMI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,6)=IBCIPTMI
S IBCIPTFI=$P(NODE3,U,4),X=IBCIPTFI,X1=20,IBCIPTFI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,7)=IBCIPTFI
S IBCIDOB=$P(NODE3,U,5),X=IBCIDOB D NOW^IBCIUT1
S X=Y,X1=16,IBCIDOB=$$FILL^IBCIUT2 K Y
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,8)=IBCIDOB
S IBCISEX=$P(NODE3,U,6),X=IBCISEX,X1=1,X4="T",IBCISEX=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,9)=IBCISEX K X4
S IBCIET=$P(NODE3,U,7),X=IBCIET D NOW^IBCIUT1 S IBCIET=Y K Y
S X=IBCIET,X1=16,IBCIET=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,10)=IBCIET
S IBCIRPID=$P(NODE3,U,8),X=IBCIRPID,X1=20,IBCIRPID=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,11)=IBCIRPID
S IBCIRPLA=$P(NODE3,U,9),X=IBCIRPLA,X1=40,IBCIRPLA=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,12)=IBCIRPLA
S IBCIRPMI=$P(NODE3,U,10),X=IBCIRPMI,X1=20,IBCIRPMI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,13)=IBCIRPMI
S IBCIRPFI=$P(NODE3,U,11),X=IBCIRPFI,X1=20,IBCIRPFI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,14)=IBCIRPFI
S IBCIRPTI=$P(NODE3,U,12),X=IBCIRPTI,X1=5,X4="T",IBCIRPTI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,15)=IBCIRPTI K X4
S IBCIRPDE=$P(NODE4,U,1),X=IBCIRPDE,X1=20,IBCIRPDE=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,16)=IBCIRPDE
S IBCIRPSP=$P(NODE4,U,2),X=IBCIRPSP,X1=10,IBCIRPSP=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,17)=IBCIRPSP
S IBCIRPDI=$P(NODE4,U,3),X=IBCIRPDI,X1=10,IBCIRPDI=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,18)=IBCIRPDI
S IBCIRPUP=$P(NODE4,U,4),X=IBCIRPUP,X1=10,IBCIRPUP=$$FILL^IBCIUT2
S ^TMP("IBCIMSG",$J,IBIFN,IBCICLNP,19)=IBCIRPUP
ICD9 ;build and check icd9 code array
N LITM,DNUM,IBCIMSG K ^TMP("IBCIMSG",$J,IBIFN,"ICD")
S IBCIMSG=1 D DIAG^IBCIUT1(IBIFN)
S LITM=0 F S LITM=$O(^TMP("IBCIMSG",$J,IBIFN,"ICD",LITM)) Q:'LITM D
.S DNUM=0 F S DNUM=$O(^TMP("IBCIMSG",$J,IBIFN,"ICD",LITM,DNUM)) Q:'DNUM D
..S X=^TMP("IBCIMSG",$J,IBIFN,"ICD",LITM,DNUM) D CCK^IBCIUT4(),TCK^IBCIUT4()
..S ^TMP("IBCIMSG",$J,IBIFN,"ICD",LITM,DNUM)=X
D INIT1^IBCIMSG1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCIMSG 3311 printed Oct 16, 2024@18:13:59 Page 2
IBCIMSG ;DSI/SLM - BUILD MESSAGE FOR CLAIMSMANAGER ;12-JAN-2001
+1 ;;2.0;INTEGRATED BILLING;**161**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ;
+1 ; kill scratch global before building it
KILL ^TMP("IBCIMSG",$JOB)
+2 if '$DATA(IBIFN)
QUIT
+3 DO INIT
+4 QUIT
+5 ;
INIT ;initialize variables for building the message
+1 SET NODE3=$GET(^IBA(351.9,IBIFN,3))
SET NODE4=$GET(^IBA(351.9,IBIFN,4))
+2 SET X=NODE3
DO TCK^IBCIUT4()
SET NODE3=X
+3 SET X=NODE4
DO TCK^IBCIUT4()
SET NODE4=X
+4 IF '$DATA(IBCISNT)
SET IBCISNT=1
+5 SET IBCICL=$PIECE(^DGCR(399,IBIFN,0),U)
SET IBCICLNP=IBCICL
+6 SET X=IBCICL
SET X1=25
SET IBCICL=$$FILL^IBCIUT2
+7 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,2)=IBCICL
+8 SET IBCIEBID=$$NOW^XLFDT
SET X=IBCIEBID
DO NOW^IBCIUT1
SET IBCIEBID=Y
KILL Y
+9 SET X=IBCIEBID
SET X1=25
SET IBCIEBID=$$FILL^IBCIUT2
+10 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,1)=IBCIEBID
+11 SET IBCIPID=$PIECE(NODE3,U,1)
SET X=IBCIPID
SET X1=20
SET IBCIPID=$$FILL^IBCIUT2
+12 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,3)=IBCIPID
+13 SET IBCIAPID=""
SET X=$GET(IBCIAPID)
SET X1=20
SET IBCIAPID=$$FILL^IBCIUT2
+14 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,4)=IBCIAPID
+15 SET IBCIPTLA=$PIECE(NODE3,U,2)
SET X=IBCIPTLA
SET X1=40
SET IBCIPTLA=$$FILL^IBCIUT2
+16 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,5)=IBCIPTLA
+17 SET IBCIPTMI=$PIECE(NODE3,U,3)
SET X=IBCIPTMI
SET X1=20
SET IBCIPTMI=$$FILL^IBCIUT2
+18 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,6)=IBCIPTMI
+19 SET IBCIPTFI=$PIECE(NODE3,U,4)
SET X=IBCIPTFI
SET X1=20
SET IBCIPTFI=$$FILL^IBCIUT2
+20 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,7)=IBCIPTFI
+21 SET IBCIDOB=$PIECE(NODE3,U,5)
SET X=IBCIDOB
DO NOW^IBCIUT1
+22 SET X=Y
SET X1=16
SET IBCIDOB=$$FILL^IBCIUT2
KILL Y
+23 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,8)=IBCIDOB
+24 SET IBCISEX=$PIECE(NODE3,U,6)
SET X=IBCISEX
SET X1=1
SET X4="T"
SET IBCISEX=$$FILL^IBCIUT2
+25 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,9)=IBCISEX
KILL X4
+26 SET IBCIET=$PIECE(NODE3,U,7)
SET X=IBCIET
DO NOW^IBCIUT1
SET IBCIET=Y
KILL Y
+27 SET X=IBCIET
SET X1=16
SET IBCIET=$$FILL^IBCIUT2
+28 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,10)=IBCIET
+29 SET IBCIRPID=$PIECE(NODE3,U,8)
SET X=IBCIRPID
SET X1=20
SET IBCIRPID=$$FILL^IBCIUT2
+30 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,11)=IBCIRPID
+31 SET IBCIRPLA=$PIECE(NODE3,U,9)
SET X=IBCIRPLA
SET X1=40
SET IBCIRPLA=$$FILL^IBCIUT2
+32 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,12)=IBCIRPLA
+33 SET IBCIRPMI=$PIECE(NODE3,U,10)
SET X=IBCIRPMI
SET X1=20
SET IBCIRPMI=$$FILL^IBCIUT2
+34 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,13)=IBCIRPMI
+35 SET IBCIRPFI=$PIECE(NODE3,U,11)
SET X=IBCIRPFI
SET X1=20
SET IBCIRPFI=$$FILL^IBCIUT2
+36 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,14)=IBCIRPFI
+37 SET IBCIRPTI=$PIECE(NODE3,U,12)
SET X=IBCIRPTI
SET X1=5
SET X4="T"
SET IBCIRPTI=$$FILL^IBCIUT2
+38 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,15)=IBCIRPTI
KILL X4
+39 SET IBCIRPDE=$PIECE(NODE4,U,1)
SET X=IBCIRPDE
SET X1=20
SET IBCIRPDE=$$FILL^IBCIUT2
+40 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,16)=IBCIRPDE
+41 SET IBCIRPSP=$PIECE(NODE4,U,2)
SET X=IBCIRPSP
SET X1=10
SET IBCIRPSP=$$FILL^IBCIUT2
+42 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,17)=IBCIRPSP
+43 SET IBCIRPDI=$PIECE(NODE4,U,3)
SET X=IBCIRPDI
SET X1=10
SET IBCIRPDI=$$FILL^IBCIUT2
+44 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,18)=IBCIRPDI
+45 SET IBCIRPUP=$PIECE(NODE4,U,4)
SET X=IBCIRPUP
SET X1=10
SET IBCIRPUP=$$FILL^IBCIUT2
+46 SET ^TMP("IBCIMSG",$JOB,IBIFN,IBCICLNP,19)=IBCIRPUP
ICD9 ;build and check icd9 code array
+1 NEW LITM,DNUM,IBCIMSG
KILL ^TMP("IBCIMSG",$JOB,IBIFN,"ICD")
+2 SET IBCIMSG=1
DO DIAG^IBCIUT1(IBIFN)
+3 SET LITM=0
FOR
SET LITM=$ORDER(^TMP("IBCIMSG",$JOB,IBIFN,"ICD",LITM))
if 'LITM
QUIT
Begin DoDot:1
+4 SET DNUM=0
FOR
SET DNUM=$ORDER(^TMP("IBCIMSG",$JOB,IBIFN,"ICD",LITM,DNUM))
if 'DNUM
QUIT
Begin DoDot:2
+5 SET X=^TMP("IBCIMSG",$JOB,IBIFN,"ICD",LITM,DNUM)
DO CCK^IBCIUT4()
DO TCK^IBCIUT4()
+6 SET ^TMP("IBCIMSG",$JOB,IBIFN,"ICD",LITM,DNUM)=X
End DoDot:2
End DoDot:1
+7 DO INIT1^IBCIMSG1
+8 QUIT
