Routine: IBCSC4

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

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

 ;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)

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)"

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))

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

IBCSC4.m