IBCSC4 ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC) ;27 MAY 88 10:17
;;2.0;INTEGRATED BILLING;**52,51,210,245,155,287,349,403,400,461,592,718**;21-MAR-94;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;MAP TO DGCRSC4
;
EN I $P(^DGCR(399,IBIFN,0),"^",5)>2 G EN^IBCSC5
I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
D ^IBCSCU S IBSR=4,IBSR1="",IBV1="0000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1),IBUC="UNSPECIFIED CODE"
S:IBV IBV1="11111111"
D H^IBCSCU F I=1:1:4 S Y="Q"_I_"^IBCVA" D @Y
D INP
S IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
D:DGPT(0)]"" DX^IBCSC4A D OCC^IBCVA1
I '$P(DGPT(0),U,6) W !?26,$S('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")
S J=$P(IB("U"),U,20),J=$S(J=99:"",J="":"",J=0:"",$L(J)=1:".0"_J,1:"."_J)
S Z=1 X IBWW W " Admission : " S I=$S($P(DGPT(0),U,2)]"":$P(DGPT(0),U,2),1:$P(IBIP,U,2)_J) S:$P(I,".",2)=""&I $P(I,".",2)="2400"
S Y=$$FMTE^XLFDT(I,"1P")
W Y,?49,"Accident Hour: ",$S($P(IB("U"),U,10)=99:IBU,$P(IB("U"),U,10)'="":$P(IB("U"),U,10),1:IBU)
W !?4,"Source : " S I=$P(^DD(399,159,0),U,3),I=$P($P(I,";",($P(IB("U"),U,9))),":",2) W I
;
; IB*2*400 - new values added to field# 158
N ATIN,ATEX
S ATIN=+$P($G(IB("U")),U,8),ATEX=""
I ATIN S ATEX=$$EXTERNAL^DILFD(399,158,,ATIN)
I ATIN=9 S ATEX="INFO NOT AVAIL" ; so it fits on the screen
I ATEX="" S ATEX=IBU
W ?58,"Type: ",ATEX
;
D OT
S Z=2 X IBWW
W " Discharge : " S Y=$S($P(IBIP,U,6)>0:$P(IBIP,U,6),1:"") X ^DD("DD") W $S(Y]"":Y,1:IBU)
W !?4,"Status : ",$S($P(IB("U"),U,12)]""&($D(^DGCR(399.1,(+$P(IB("U"),"^",12)),0))):$P(^(0),"^",1),1:IBU)
N IBPOARR,IBDATE,NEEDPOA,POA
D SET^IBCSC4D(IBIFN,"",.IBPOARR)
S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The STATEMENT TO DATE of the bill
S NEEDPOA=$$INPAT^IBCEF(IBIFN)&($$FT^IBCEF(IBIFN)=3)
S Z=3,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX(0,IBDATE),POA="" S:NEEDPOA&(Y'="") POA=$P(IBPOARR(+Y),U,3)
W $S(Y'="":$E($P(Y,U,4),1,47)_" - "_$P(Y,U,2)_$S(POA=""!(POA=1):"",1:" ("_POA_")"),$$DXREQ(IBIFN):IBU,1:IBUN)
F I=1:1:4 S Y=$$DX(+Y,IBDATE) Q:Y="" D
.S POA="" S:NEEDPOA POA=$P(IBPOARR(+Y),U,3)
.W !?4,"Other Diag.: ",$E($P(Y,U,4),1,47)_" - "_$P(Y,U,2)_$S(POA=""!(POA=1):"",1:" ("_POA_")")
.Q
I +Y S Y=$$DX(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
S Z=4,IBW=1,DGPCM=$P(IB(0),U,9) X IBWW W " Cod. Method: ",$S(DGPCM="":IBUN,DGPCM=9:"ICD",DGPCM=4:"CPT-4",1:"HCPCS")
D:$D(IBPROC) WRT^IBCSC5
OCC ;
S Z=$S($P(IB(0),U,5)<3:5,1:6)
S IBW=1 X IBWW W " Pros. Items: " S Y=$$PD^IBCSC5 I 'Y W IBUN
S Z=$S($P(IB(0),U,5)<3:6,1:7) X IBWW
W " Occ. Code : " F I=1:1:5 I $D(IBO(I)) W:I>1 !?4,"Occ. Code : ",$E(IBOCN(I),1,27) W:I=1 $E(IBOCN(I),1,27) S Y=IBOCD(I) X ^DD("DD") W ?55,Y S Y=IBOCD2(I) I +Y X ^DD("DD") W " - ",Y
I '$D(IBO) W IBUN
I $D(IBO)=1,IBO="" W IBUN
;JWS;IB*2.0*592 US1108 - Dental
I $$FT^IBCEF(IBIFN)=7 D Q^IBCSC4B G ^IBCSCP
S Z=$S($P(IB(0),U,5)<3:7,1:8) X IBWW
W " Cond. Code : " F I=1:1:5 I $D(IBCC(I)) W:I>1 !?4,"Cond. Code : ",IBCCN(I) W:I=1 IBCCN(I)
I '$D(IBCC) W IBUN
I $D(IBCC)=1,IBCC="" W IBUN
S Z=$S($P(IB(0),U,5)<3:8,1:9)
X IBWW W " Value Code : " S IBVC=0
I $$FT^IBCEF(IBIFN)'=2 D
. ;IB*2.0*718;JWS;EBILL-99;EBILL-103;11/9/21;display only up to 5 value codes
. D VC^IBCVA1 I +IBVC S J=1,I=0 F S I=$O(IBVC(I)) Q:'I Q:J>5 W:J>1 !,?3," Value Code : " W ?17,$E($P(IBVC(I),U,2),1,40),?58,$P(IBVC(I),U,3) S J=J+1
. ;IB*2.0*718v4;JWS;EBILL-99;EBILL-103;11/16/21;variable J was unreliable.
. I +$G(IBVC)>5 W !?4,"***There are more Value Codes associated with this bill.***",!
W:'IBVC IBUN K IBVC
D Q^IBCSC4B G ^IBCSCP
Q
OCC1 W $P(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$P($$PRCD^IBCEF1($P(^DGCR(399,IBIFN,"CP",I,0),U)),U),?55,"Date: ",Y
Q
;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160)
; ^ source of addmis (399,159) ^ typ of addmiss (399,158)
; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)
; ^ dxls (45,79) ^ disch bedsection (399,161)
INP F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
S IBPTF=$P(IB(0),U,8) F I=0,70 S DGPT(I)=$S(IBPTF="":"",$D(^DGPT(IBPTF,I)):^(I),1:"")
F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
S IBIP=IBPTF_"^"_$S($P(DGPT(0),"^",2)]"":$P(DGPT(0),"^",2),1:$P(IB(0),"^",3))_"^"_$P(IB("U"),"^",10)_"^"_$P(IB("U"),"^",9)_"^"_$P(IB("U"),"^",8)_"^"_$S(+DGPT(70)>0:+DGPT(70),1:$P(IB(0),"^",16))_"^"
S IBIP=IBIP_$P(IB("U"),"^",12)_"^"_$S($D(DGPT(70)):$P(DGPT(70),"^",10),1:"")_"^"_$P(IB("U"),"^",11)
Q
SET ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W "" "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"
Q
;
DX(ORDER,IBDATE) ; Get next diagnosis data
N IBX
S IBX=""
S ORDER=$O(IBPOARR(ORDER))
I ORDER S IBX=ORDER_U_$$ICD9^IBACSV(+IBPOARR(ORDER),$G(IBDATE))
Q IBX
;
OT ; print Other Care (SNF) multiple
N IBX,IBY,IBN I '$O(^DGCR(399,IBIFN,"OT",0)) W !,?4,"SNF Care : UNSPECIFIED [NOT REQUIRED]"
S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"OT",IBX)) Q:'IBX D
. S IBY=$G(^DGCR(399,IBIFN,"OT",IBX,0)) Q:'IBY
. S IBN=$P($G(^DGCR(399.1,+IBY,0)),U,1),IBN=$S(IBN["SKILLED":"SNF Care ",IBN["SUB-ACUTE":"Sub-Acute",1:"Unknown ")
. W !,?4,IBN," : ",$$FMTE^XLFDT(+$P(IBY,U,2))," - ",$$FMTE^XLFDT(+$P(IBY,U,3))
Q
;
DXREQ(IBIFN) ; Is the principle diagnosis code required or not?
; Function returns true (1) if DX is required for this bill, otherwise 0
NEW REQ,IBFT
S REQ=0,IBFT=$$FT^IBCEF(IBIFN)
I IBFT=2 S REQ=1 G DXREQX ; required for CMS-1500
I IBFT=3,$$WNRBILL^IBEFUNC(IBIFN) S REQ=1 G DXREQX ; UB with Medicare (WNR) current payer
DXREQX ;
Q REQ
;
;IBCSC4
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4 5867 printed Mar 13, 2025@21:25:11 Page 2
IBCSC4 ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC) ;27 MAY 88 10:17
+1 ;;2.0;INTEGRATED BILLING;**52,51,210,245,155,287,349,403,400,461,592,718**;21-MAR-94;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSC4
+5 ;
EN IF $PIECE(^DGCR(399,IBIFN,0),"^",5)>2
GOTO EN^IBCSC5
+1 IF $DATA(IBASKCOD)
KILL IBASKCOD
DO CODMUL^IBCU7
IF $$BILLCPT^IBCRU4(IBIFN)
DO ASK^IBCU7A(IBIFN)
SET DGRVRCAL=1
+2 IF $DATA(DGRVRCAL)
DO ^IBCU6
KILL DGRVRCAL
+3 DO ^IBCSCU
SET IBSR=4
SET IBSR1=""
SET IBV1="0000000"_$SELECT($$FT^IBCEF(IBIFN)'=2:0,1:1)
SET IBUC="UNSPECIFIED CODE"
+4 if IBV
SET IBV1="11111111"
+5 DO H^IBCSCU
FOR I=1:1:4
SET Y="Q"_I_"^IBCVA"
DO @Y
+6 DO INP
+7 SET IBBT=$PIECE(IB(0),"^",4)_$PIECE(IB(0),"^",5)_$PIECE(IB(0),"^",6)
+8 if DGPT(0)]""
DO DX^IBCSC4A
DO OCC^IBCVA1
+9 IF '$PIECE(DGPT(0),U,6)
WRITE !?26,$SELECT('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")
+10 SET J=$PIECE(IB("U"),U,20)
SET J=$SELECT(J=99:"",J="":"",J=0:"",$LENGTH(J)=1:".0"_J,1:"."_J)
+11 SET Z=1
XECUTE IBWW
WRITE " Admission : "
SET I=$SELECT($PIECE(DGPT(0),U,2)]"":$PIECE(DGPT(0),U,2),1:$PIECE(IBIP,U,2)_J)
if $PIECE(I,".",2)=""&I
SET $PIECE(I,".",2)="2400"
+12 SET Y=$$FMTE^XLFDT(I,"1P")
+13 WRITE Y,?49,"Accident Hour: ",$SELECT($PIECE(IB("U"),U,10)=99:IBU,$PIECE(IB("U"),U,10)'="":$PIECE(IB("U"),U,10),1:IBU)
+14 WRITE !?4,"Source : "
SET I=$PIECE(^DD(399,159,0),U,3)
SET I=$PIECE($PIECE(I,";",($PIECE(IB("U"),U,9))),":",2)
WRITE I
+15 ;
+16 ; IB*2*400 - new values added to field# 158
+17 NEW ATIN,ATEX
+18 SET ATIN=+$PIECE($GET(IB("U")),U,8)
SET ATEX=""
+19 IF ATIN
SET ATEX=$$EXTERNAL^DILFD(399,158,,ATIN)
+20 ; so it fits on the screen
IF ATIN=9
SET ATEX="INFO NOT AVAIL"
+21 IF ATEX=""
SET ATEX=IBU
+22 WRITE ?58,"Type: ",ATEX
+23 ;
+24 DO OT
+25 SET Z=2
XECUTE IBWW
+26 WRITE " Discharge : "
SET Y=$SELECT($PIECE(IBIP,U,6)>0:$PIECE(IBIP,U,6),1:"")
XECUTE ^DD("DD")
WRITE $SELECT(Y]"":Y,1:IBU)
+27 WRITE !?4,"Status : ",$SELECT($PIECE(IB("U"),U,12)]""&($DATA(^DGCR(399.1,(+$PIECE(IB("U"),"^",12)),0))):$PIECE(^(0),"^",1),1:IBU)
+28 NEW IBPOARR,IBDATE,NEEDPOA,POA
+29 DO SET^IBCSC4D(IBIFN,"",.IBPOARR)
+30 ; The STATEMENT TO DATE of the bill
SET IBDATE=$$BDATE^IBACSV(+$GET(IBIFN))
+31 SET NEEDPOA=$$INPAT^IBCEF(IBIFN)&($$FT^IBCEF(IBIFN)=3)
+32 SET Z=3
SET IBW=1
XECUTE IBWW
WRITE " Prin. Diag.: "
SET Y=$$DX(0,IBDATE)
SET POA=""
if NEEDPOA&(Y'="")
SET POA=$PIECE(IBPOARR(+Y),U,3)
+33 WRITE $SELECT(Y'="":$EXTRACT($PIECE(Y,U,4),1,47)_" - "_$PIECE(Y,U,2)_$SELECT(POA=""!(POA=1):"",1:" ("_POA_")"),$$DXREQ(IBIFN):IBU,1:IBUN)
+34 FOR I=1:1:4
SET Y=$$DX(+Y,IBDATE)
if Y=""
QUIT
Begin DoDot:1
+35 SET POA=""
if NEEDPOA
SET POA=$PIECE(IBPOARR(+Y),U,3)
+36 WRITE !?4,"Other Diag.: ",$EXTRACT($PIECE(Y,U,4),1,47)_" - "_$PIECE(Y,U,2)_$SELECT(POA=""!(POA=1):"",1:" ("_POA_")")
+37 QUIT
End DoDot:1
+38 IF +Y
SET Y=$$DX(+Y,IBDATE)
IF +Y
WRITE !?4,"***There are more diagnoses associated with this bill.***"
+39 SET Z=4
SET IBW=1
SET DGPCM=$PIECE(IB(0),U,9)
XECUTE IBWW
WRITE " Cod. Method: ",$SELECT(DGPCM="":IBUN,DGPCM=9:"ICD",DGPCM=4:"CPT-4",1:"HCPCS")
+40 if $DATA(IBPROC)
DO WRT^IBCSC5
OCC ;
+1 SET Z=$SELECT($PIECE(IB(0),U,5)<3:5,1:6)
+2 SET IBW=1
XECUTE IBWW
WRITE " Pros. Items: "
SET Y=$$PD^IBCSC5
IF 'Y
WRITE IBUN
+3 SET Z=$SELECT($PIECE(IB(0),U,5)<3:6,1:7)
XECUTE IBWW
+4 WRITE " Occ. Code : "
FOR I=1:1:5
IF $DATA(IBO(I))
if I>1
WRITE !?4,"Occ. Code : ",$EXTRACT(IBOCN(I),1,27)
if I=1
WRITE $EXTRACT(IBOCN(I),1,27)
SET Y=IBOCD(I)
XECUTE ^DD("DD")
WRITE ?55,Y
SET Y=IBOCD2(I)
IF +Y
XECUTE ^DD("DD")
WRITE " - ",Y
+5 IF '$DATA(IBO)
WRITE IBUN
+6 IF $DATA(IBO)=1
IF IBO=""
WRITE IBUN
+7 ;JWS;IB*2.0*592 US1108 - Dental
+8 IF $$FT^IBCEF(IBIFN)=7
DO Q^IBCSC4B
GOTO ^IBCSCP
+9 SET Z=$SELECT($PIECE(IB(0),U,5)<3:7,1:8)
XECUTE IBWW
+10 WRITE " Cond. Code : "
FOR I=1:1:5
IF $DATA(IBCC(I))
if I>1
WRITE !?4,"Cond. Code : ",IBCCN(I)
if I=1
WRITE IBCCN(I)
+11 IF '$DATA(IBCC)
WRITE IBUN
+12 IF $DATA(IBCC)=1
IF IBCC=""
WRITE IBUN
+13 SET Z=$SELECT($PIECE(IB(0),U,5)<3:8,1:9)
+14 XECUTE IBWW
WRITE " Value Code : "
SET IBVC=0
+15 IF $$FT^IBCEF(IBIFN)'=2
Begin DoDot:1
+16 ;IB*2.0*718;JWS;EBILL-99;EBILL-103;11/9/21;display only up to 5 value codes
+17 DO VC^IBCVA1
IF +IBVC
SET J=1
SET I=0
FOR
SET I=$ORDER(IBVC(I))
if 'I
QUIT
if J>5
QUIT
if J>1
WRITE !,?3," Value Code : "
WRITE ?17,$EXTRACT($PIECE(IBVC(I),U,2),1,40),?58,$PIECE(IBVC(I),U,3)
SET J=J+1
+18 ;IB*2.0*718v4;JWS;EBILL-99;EBILL-103;11/16/21;variable J was unreliable.
+19 IF +$GET(IBVC)>5
WRITE !?4,"***There are more Value Codes associated with this bill.***",!
End DoDot:1
+20 if 'IBVC
WRITE IBUN
KILL IBVC
+21 DO Q^IBCSC4B
GOTO ^IBCSCP
+22 QUIT
OCC1 WRITE $PIECE(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$PIECE($$PRCD^IBCEF1($PIECE(^DGCR(399,IBIFN,"CP",I,0),U)),U),?55,"Date: ",Y
+1 QUIT
+2 ;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160)
+3 ; ^ source of addmis (399,159) ^ typ of addmiss (399,158)
+4 ; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)
+5 ; ^ dxls (45,79) ^ disch bedsection (399,161)
INP FOR I="C","U",0
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
+1 SET IBPTF=$PIECE(IB(0),U,8)
FOR I=0,70
SET DGPT(I)=$SELECT(IBPTF="":"",$DATA(^DGPT(IBPTF,I)):^(I),1:"")
+2 FOR I="C","U",0
SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")
+3 SET IBIP=IBPTF_"^"_$SELECT($PIECE(DGPT(0),"^",2)]"":$PIECE(DGPT(0),"^",2),1:$PIECE(IB(0),"^",3))_"^"_$PIECE(IB("U"),"^",10)_"^"_$PIECE(IB("U"),"^",9)_"^"_$PIECE(IB("U"),"^",8)_"^"_$SELECT(+DGPT(70)>0:+DGPT(70),1:$PIECE(IB(0),"^",16))_"^"
+4 SET IBIP=IBIP_$PIECE(IB("U"),"^",12)_"^"_$SELECT($DATA(DGPT(70)):$PIECE(DGPT(70),"^",10),1:"")_"^"_$PIECE(IB("U"),"^",11)
+5 QUIT
SET ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W "" "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"
+1 QUIT
+2 ;
DX(ORDER,IBDATE) ; Get next diagnosis data
+1 NEW IBX
+2 SET IBX=""
+3 SET ORDER=$ORDER(IBPOARR(ORDER))
+4 IF ORDER
SET IBX=ORDER_U_$$ICD9^IBACSV(+IBPOARR(ORDER),$GET(IBDATE))
+5 QUIT IBX
+6 ;
OT ; print Other Care (SNF) multiple
+1 NEW IBX,IBY,IBN
IF '$ORDER(^DGCR(399,IBIFN,"OT",0))
WRITE !,?4,"SNF Care : UNSPECIFIED [NOT REQUIRED]"
+2 SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399,IBIFN,"OT",IBX))
if 'IBX
QUIT
Begin DoDot:1
+3 SET IBY=$GET(^DGCR(399,IBIFN,"OT",IBX,0))
if 'IBY
QUIT
+4 SET IBN=$PIECE($GET(^DGCR(399.1,+IBY,0)),U,1)
SET IBN=$SELECT(IBN["SKILLED":"SNF Care ",IBN["SUB-ACUTE":"Sub-Acute",1:"Unknown ")
+5 WRITE !,?4,IBN," : ",$$FMTE^XLFDT(+$PIECE(IBY,U,2))," - ",$$FMTE^XLFDT(+$PIECE(IBY,U,3))
End DoDot:1
+6 QUIT
+7 ;
DXREQ(IBIFN) ; Is the principle diagnosis code required or not?
+1 ; Function returns true (1) if DX is required for this bill, otherwise 0
+2 NEW REQ,IBFT
+3 SET REQ=0
SET IBFT=$$FT^IBCEF(IBIFN)
+4 ; required for CMS-1500
IF IBFT=2
SET REQ=1
GOTO DXREQX
+5 ; UB with Medicare (WNR) current payer
IF IBFT=3
IF $$WNRBILL^IBEFUNC(IBIFN)
SET REQ=1
GOTO DXREQX
DXREQX ;
+1 QUIT REQ
+2 ;
+3 ;IBCSC4
