- 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 Feb 18, 2025@23:39:43 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
