IBCSC6.m

IBCSC6 ;ALB/MJB - MCCR SCREEN 6 (INPT. BILLING INFO) ;27 MAY 88 10:19

 ;;2.0;INTEGRATED BILLING;**52,80,109,106,51,137,343,400,432,623**;21-MAR-94;Build 70

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ;MAP TO DGCRSC6

 ;

EN I $P(^DGCR(399,IBIFN,0),"^",5)>2 G EN^IBCSC7

 I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL

 D ^IBCSCU S IBSR=6,IBSR1="",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1",0,"U2","U3" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")

 D H^IBCSCU

 S IBBT=$P(IB(0),U,24)_$P(IB(0),U,5)_$P(IB(0),U,26)

 S IBBT1=$P(IB(0),U,24)_$P($G(^DGCR(399.1,+$P(IB(0),U,25),0)),U,2)_$P(IB(0),U,26)

 D 4^IBCVA1,5^IBCVA1

 ;

1 S Z=1,IBW=1 X IBWW W " Bill Type   : ",$S('$D(IBBT1):IBU,IBBT1="":IBU,1:IBBT1)

 W $J("",14),"Loc. of Care: ",$E($G(IBBTP1),1,30) K IBBTP1

 ;W !?4,"Covered Days: ",$S(IB("U2")="":IBU,$P(IB("U2"),U,2)'="":$P(IB("U2"),U,2),1:IBU)

 W !?4,"Charge Type : ",$S($P(IB(0),U,27)=1:"INSTITUTIONAL",$P(IB(0),U,27)=2:"PROFESSIONAL",1:IBU)

 ; IB*2.0*432 - remove Covered, Non-covered and co-insurance days

 ;W !?4,"Non-Cov Days: ",$S(IB("U2")="":IBU,$P(IB("U2"),U,3)'="":$P(IB("U2"),U,3),1:IBU)

 W ?38,"Timeframe: ",$S($D(IBBTP3):$E(IBBTP3,1,30),1:"") K IBBTP3

 W !?4,"Form Type   : ",$P($G(^IBE(353,+$P(IB(0),U,19),0)),U,1)

 W ?39,"Division: ",$E($P($G(^DG(40.8,+$P(IB(0),U,22),0)),U,1),1,30)

 W !,?4,"Bill Classif: ",$E($G(IBBTP2),1,30) K IBBTP2

 ;W ?34,"Co-Insur Days: ",$S($P(IB("U2"),U,7)="":$S($$MCRONBIL^IBEFUNC(IBIFN):IBU,1:IBUN),1:$P(IB("U2"),U,7))

 ;

ROI S Z=2,IBW=1 X IBWW

 W " Sensitive?  : ",$S(IB("U")="":IBU,$P(IB("U"),U,5)="":IBU,$P(IB("U"),U,5)=1:"YES",1:"NO")

 W ?46,"Assignment: ",$S(IB("U")="":IBU,$P(IB("U"),U,6)="":IBU,$P(IB("U"),U,6)["n":"NO",$P(IB("U"),U,6)["N":"NO",$P(IB("U"),U,6)=0:"NO",1:"YES")

 ;/vd - IB*2.0*623 (US4995) - Modified the following line of code with the following conditional to validate that a

 ;                            claim is ROI Eligible based upon the Date of Service.

 ;I $P(IB("U"),U,5)=1 W !?4,"R.O.I. Form : ",$S($P(IB("U"),U,7)=1:"COMPLETED",$P(IB("U"),U,7)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

 I $$ROIDTCK^IBCEU7(IBIFN) D

 . I $P(IB("U"),U,5)=1 W !?4,"R.O.I. Form : ",$S($P(IB("U"),U,7)=1:"COMPLETED",$P(IB("U"),U,7)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

 S IBOA="01^02^03^04^05^06^" F I=1:1:5 Q:'$D(IBOCN(I))  I IBOA[IBOCN(I)_"^" S IBOX=1

 W:$D(IBOX) !,?4,"Pow of Atty : ",$S($P(IB("U"),U,3)=1:"COMPLETED",$P(IB("U"),U,3)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

 ;

3 S Z=3,IBW=1 X IBWW D FROMTO

 ;

BED S Z=4,IBW=1 X IBWW

 W " Bedsection  : ",$S(IB("U")="":IBU,$P(IB("U"),U,11)'="":$P(^DGCR(399.1,$P(IB("U"),U,11),0),U,1),1:IBU)

 W !?4,"LOS         : ",IBLS

 ;

 I $P($G(^DPT(DFN,.3)),"^")="Y" D SC I IBSCM>0 W !?4,"PTF record indicates ",IBSCM," of ",IBM," movements are for Service Connected Care."

 ;

REV S Z=5,IBREVC=0,IBW=1 X IBWW W " Rev. Code   : " F I=1:1:8 Q:'$D(IBREVC(I))  D:$S(IBREVC<7:1,1:$P(IBREVC(I),U,9)="") REV^IBCSC61 S IBREVC=IBREVC+1 Q:IBREVC>7

 I $G(IBREVC)>9 W !,?4,"Too many Revenue Codes to display, enter '5' to list"

BILL D OFFSET^IBCSC61

 I $G(IBUCH),$$FT^IBCEF(IBIFN)=3 S X=IBUCH,X2="2$" D COMMA^%DTC W !,?39,"Non-Cov: ",X

 ;

RS S Z=6,IBW=1 X IBWW W " Rate Sched  : (re-calculate charges)"

 ;

PRPAY S Z=7,IBW=1 X IBWW

 S IB("M1")=$G(^DGCR(399,IBIFN,"M1")),X3=0,IBI="Prior Payments:" F X=0,1,2 D

 . S X1=$P(IB("U2"),U,(X+4)),X2=$P(IB("M1"),U,(5+X)) I X1="",X2="" Q

 . S IBI=IBI_$J("",(17-$L(IBI)))_$S(X=0:"Primary",X=1:"Secondary",X=2:"Tertiary",1:"")

 . S IBI=IBI_$J("",(28-$L(IBI)))_$S(X1'="":$J(X1,11,2),1:IBU)

 . S IBI=IBI_$J("",(50-$L(IBI)))_"Bill #: "_$S(+X2:$P($G(^DGCR(399,+X2,0)),U,1),1:IBU)

 . W:'X3 " " W:X3 !,?4 W IBI S X3=1,IBI=""

 I 'X3 W " Prior Claims: ",IBU

 ;

 G ^IBCSCP

 Q

 ;

FROMTO ;  - Print From and To dates of bill

 W " Bill From   : " S Y=$P(IB("U"),"^") D D^DIQ W $S($L(Y):Y,1:IBU)

 W ?49,"Bill To: " S Y=$P(IB("U"),"^",2) D D^DIQ W $S($L(Y):Y,1:IBU)

 Q

 ;

SC ;  -if patient is sc, are movements for sc care

 S PTF=$P(IB(0),"^",8)

 ;

SC1 ;

 ;  -input ptf

 ;

 ;  -output IBm   = number of movements

 ;          IBscm = number of SC movements

 S (IBM,IBSCM,M)=0

 I $S('PTF:1,'$D(^DGPT(PTF,0)):1,1:0) Q

 F  S M=$O(^DGPT(PTF,"M",M)) Q:'M  S IBM=IBM+1 I $P($G(^DGPT(PTF,"M",M,0)),"^",18)=1 S IBSCM=IBSCM+1

 Q

 ;IBCSC6

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCSC6   4326     printed  Mar 13, 2025@21:25:21                                                                                                                                                                                                      Page 2

IBCSC6    ;ALB/MJB - MCCR SCREEN 6 (INPT. BILLING INFO) ;27 MAY 88 10:19

 +1       ;;2.0;INTEGRATED BILLING;**52,80,109,106,51,137,343,400,432,623**;21-MAR-94;Build 70

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;MAP TO DGCRSC6

 +5       ;

EN         IF $PIECE(^DGCR(399,IBIFN,0),"^",5)>2

               GOTO EN^IBCSC7

 +1        IF $DATA(DGRVRCAL)

               DO ^IBCU6

               KILL DGRVRCAL

 +2        DO ^IBCSCU

           SET IBSR=6

           SET IBSR1=""

           SET IBV1="0000000"

           if IBV

               SET IBV1="1111111"

           FOR I="U","U1",0,"U2","U3"

               SET IB(I)=$SELECT($DATA(^DGCR(399,IBIFN,I)):^(I),1:"")

 +3        DO H^IBCSCU

 +4        SET IBBT=$PIECE(IB(0),U,24)_$PIECE(IB(0),U,5)_$PIECE(IB(0),U,26)

 +5        SET IBBT1=$PIECE(IB(0),U,24)_$PIECE($GET(^DGCR(399.1,+$PIECE(IB(0),U,25),0)),U,2)_$PIECE(IB(0),U,26)

 +6        DO 4^IBCVA1

           DO 5^IBCVA1

 +7       ;

1          SET Z=1

           SET IBW=1

           XECUTE IBWW

           WRITE " Bill Type   : ",$SELECT('$DATA(IBBT1):IBU,IBBT1="":IBU,1:IBBT1)

 +1        WRITE $JUSTIFY("",14),"Loc. of Care: ",$EXTRACT($GET(IBBTP1),1,30)

           KILL IBBTP1

 +2       ;W !?4,"Covered Days: ",$S(IB("U2")="":IBU,$P(IB("U2"),U,2)'="":$P(IB("U2"),U,2),1:IBU)

 +3        WRITE !?4,"Charge Type : ",$SELECT($PIECE(IB(0),U,27)=1:"INSTITUTIONAL",$PIECE(IB(0),U,27)=2:"PROFESSIONAL",1:IBU)

 +4       ; IB*2.0*432 - remove Covered, Non-covered and co-insurance days

 +5       ;W !?4,"Non-Cov Days: ",$S(IB("U2")="":IBU,$P(IB("U2"),U,3)'="":$P(IB("U2"),U,3),1:IBU)

 +6        WRITE ?38,"Timeframe: ",$SELECT($DATA(IBBTP3):$EXTRACT(IBBTP3,1,30),1:"")

           KILL IBBTP3

 +7        WRITE !?4,"Form Type   : ",$PIECE($GET(^IBE(353,+$PIECE(IB(0),U,19),0)),U,1)

 +8        WRITE ?39,"Division: ",$EXTRACT($PIECE($GET(^DG(40.8,+$PIECE(IB(0),U,22),0)),U,1),1,30)

 +9        WRITE !,?4,"Bill Classif: ",$EXTRACT($GET(IBBTP2),1,30)

           KILL IBBTP2

 +10      ;W ?34,"Co-Insur Days: ",$S($P(IB("U2"),U,7)="":$S($$MCRONBIL^IBEFUNC(IBIFN):IBU,1:IBUN),1:$P(IB("U2"),U,7))

 +11      ;

ROI        SET Z=2

           SET IBW=1

           XECUTE IBWW

 +1        WRITE " Sensitive?  : ",$SELECT(IB("U")="":IBU,$PIECE(IB("U"),U,5)="":IBU,$PIECE(IB("U"),U,5)=1:"YES",1:"NO")

 +2        WRITE ?46,"Assignment: ",$SELECT(IB("U")="":IBU,$PIECE(IB("U"),U,6)="":IBU,$PIECE(IB("U"),U,6)["n":"NO",$PIECE(IB("U"),U,6)["N":"NO",$PIECE(IB("U"),U,6)=0:"NO",1:"YES")

 +3       ;/vd - IB*2.0*623 (US4995) - Modified the following line of code with the following conditional to validate that a

 +4       ;                            claim is ROI Eligible based upon the Date of Service.

 +5       ;I $P(IB("U"),U,5)=1 W !?4,"R.O.I. Form : ",$S($P(IB("U"),U,7)=1:"COMPLETED",$P(IB("U"),U,7)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

 +6        IF $$ROIDTCK^IBCEU7(IBIFN)

               Begin DoDot:1

 +7                IF $PIECE(IB("U"),U,5)=1

                       WRITE !?4,"R.O.I. Form : ",$SELECT($PIECE(IB("U"),U,7)=1:"COMPLETED",$PIECE(IB("U"),U,7)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

               End DoDot:1

 +8        SET IBOA="01^02^03^04^05^06^"

           FOR I=1:1:5

               if '$DATA(IBOCN(I))

                   QUIT 

               IF IBOA[IBOCN(I)_"^"

                   SET IBOX=1

 +9        if $DATA(IBOX)

               WRITE !,?4,"Pow of Atty : ",$SELECT($PIECE(IB("U"),U,3)=1:"COMPLETED",$PIECE(IB("U"),U,3)=0:"NOT COMPLETED",1:"STATUS UNKNOWN")

 +10      ;

3          SET Z=3

           SET IBW=1

           XECUTE IBWW

           DO FROMTO

 +1       ;

BED        SET Z=4

           SET IBW=1

           XECUTE IBWW

 +1        WRITE " Bedsection  : ",$SELECT(IB("U")="":IBU,$PIECE(IB("U"),U,11)'="":$PIECE(^DGCR(399.1,$PIECE(IB("U"),U,11),0),U,1),1:IBU)

 +2        WRITE !?4,"LOS         : ",IBLS

 +3       ;

 +4        IF $PIECE($GET(^DPT(DFN,.3)),"^")="Y"

               DO SC

               IF IBSCM>0

                   WRITE !?4,"PTF record indicates ",IBSCM," of ",IBM," movements are for Service Connected Care."

 +5       ;

REV        SET Z=5

           SET IBREVC=0

           SET IBW=1

           XECUTE IBWW

           WRITE " Rev. Code   : "

           FOR I=1:1:8

               if '$DATA(IBREVC(I))

                   QUIT 

               if $SELECT(IBREVC<7

                   DO REV^IBCSC61

               SET IBREVC=IBREVC+1

               if IBREVC>7

                   QUIT 

 +1        IF $GET(IBREVC)>9

               WRITE !,?4,"Too many Revenue Codes to display, enter '5' to list"

BILL       DO OFFSET^IBCSC61

 +1        IF $GET(IBUCH)

               IF $$FT^IBCEF(IBIFN)=3

                   SET X=IBUCH

                   SET X2="2$"

                   DO COMMA^%DTC

                   WRITE !,?39,"Non-Cov: ",X

 +2       ;

RS         SET Z=6

           SET IBW=1

           XECUTE IBWW

           WRITE " Rate Sched  : (re-calculate charges)"

 +1       ;

PRPAY      SET Z=7

           SET IBW=1

           XECUTE IBWW

 +1        SET IB("M1")=$GET(^DGCR(399,IBIFN,"M1"))

           SET X3=0

           SET IBI="Prior Payments:"

           FOR X=0,1,2

               Begin DoDot:1

 +2                SET X1=$PIECE(IB("U2"),U,(X+4))

                   SET X2=$PIECE(IB("M1"),U,(5+X))

                   IF X1=""

                       IF X2=""

                           QUIT 

 +3                SET IBI=IBI_$JUSTIFY("",(17-$LENGTH(IBI)))_$SELECT(X=0:"Primary",X=1:"Secondary",X=2:"Tertiary",1:"")

 +4                SET IBI=IBI_$JUSTIFY("",(28-$LENGTH(IBI)))_$SELECT(X1'="":$JUSTIFY(X1,11,2),1:IBU)

 +5                SET IBI=IBI_$JUSTIFY("",(50-$LENGTH(IBI)))_"Bill #: "_$SELECT(+X2:$PIECE($GET(^DGCR(399,+X2,0)),U,1),1:IBU)

 +6                if 'X3

                       WRITE " "

                   if X3

                       WRITE !,?4

                   WRITE IBI

                   SET X3=1

                   SET IBI=""

               End DoDot:1

 +7        IF 'X3

               WRITE " Prior Claims: ",IBU

 +8       ;

 +9        GOTO ^IBCSCP

 +10       QUIT 

 +11      ;

FROMTO    ;  - Print From and To dates of bill

 +1        WRITE " Bill From   : "

           SET Y=$PIECE(IB("U"),"^")

           DO D^DIQ

           WRITE $SELECT($LENGTH(Y):Y,1:IBU)

 +2        WRITE ?49,"Bill To: "

           SET Y=$PIECE(IB("U"),"^",2)

           DO D^DIQ

           WRITE $SELECT($LENGTH(Y):Y,1:IBU)

 +3        QUIT 

 +4       ;

SC        ;  -if patient is sc, are movements for sc care

 +1        SET PTF=$PIECE(IB(0),"^",8)

 +2       ;

SC1       ;

 +1       ;  -input ptf

 +2       ;

 +3       ;  -output IBm   = number of movements

 +4       ;          IBscm = number of SC movements

 +5        SET (IBM,IBSCM,M)=0

 +6        IF $SELECT('PTF:1,'$DATA(^DGPT(PTF,0)):1,1:0)

               QUIT 

 +7        FOR 

               SET M=$ORDER(^DGPT(PTF,"M",M))

               if 'M

                   QUIT 

               SET IBM=IBM+1

               IF $PIECE($GET(^DGPT(PTF,"M",M,0)),"^",18)=1

                   SET IBSCM=IBSCM+1

 +8        QUIT 

 +9       ;IBCSC6