IBCSC4C.m

IBCSC4C ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43

 ;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;MAP TO DGCRSC4C

 ;

SETP S:IBP'>2 IB9=0 D S

 F F=1:1:3 Q:IB9=3  I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWO(F)_U_$S($P(IBWO(F),U,2)']"":$P(IBWO(0),U,2),1:"")

 I '$D(IB7(3)) F F=1:1:3 Q:IB9=3  I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB9=IB9+1,IB7(IB9)=IBWE(F)_U_$S($P(IBWE(F),U,2)']"":$P(IBWE(0),U,2),1:"")

 Q:"^^"[$P(IB("C"),U,4,6)!($P(IB("C"),U,4)]"")!($P(IB("C"),U,5)]"")!($P(IB("C"),U,6)]"")

 F F=1:1:3 I $D(IB7(F)),$P(^DGCR(399,IBIFN,"C"),U,(F+3))']"" S $P(^DGCR(399,IBIFN,"C"),U,(F+3))=$P(IB7(F),U,1),$P(^("C"),U,(F+10))=$P(IB7(F),U,2)

 S:$P(^DGCR(399,IBIFN,0),U,9)="" $P(^DGCR(399,IBIFN,0),U,9)=9

 Q

SETD S:IBDIA'>2 IB8=0 D S

 F F=1:1:5 Q:IB8=5  I $D(IBWO(F)),IBWO(F)]"",$P(IBWO(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWO(F),U,1)

 I '$D(IB6(5)) F F=1:1:5 Q:IB8=5  I $D(IBWE(F)),IBWE(F)]"",$P(IBWE(F),U,1)'=IBNC S IB8=IB8+1,IB6(IB8)=$P(IBWE(F),U,1)

 Q:"^^^^"[$P(IB("C"),U,14,18)!($P(IB("C"),U,14)]"")!($P(IB("C"),U,15)]"")!($P(IB("C"),U,16)]"")!($P(IB("C"),U,17)]"")!($P(IB("C"),U,18)]"")

 F F=1:1:5 I $D(IB6(F)) S $P(^DGCR(399,IBIFN,"C"),U,(F+13))=IB6(F)

 Q

SELP D S F I=1:1 W ! Q:$Y+10>IOSL

 N IBZ,IBQ

 S IBQ=0 ; Quit flag

 F I=1:1:3 W !,"ICD PROCEDURE CODE (",I,"): " D  Q:IBQ

 . S IBPX=$P(IB("C"),U,(I+3))

 . I IBPX S IBZ=$$ICD0^IBACSV(+IBPX) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "

 . R X:DTIME I '$T!(X["^") S IBQ=1 Q

 . D CHP

 . I $D(IB3) D PD

 . D S

 Q

 ;

PD S %DT("A")="      PROCEDURE DATE ("_I_"): ",%DT="AEX" D ^%DT I Y>0 S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=+Y,IB("C")=^DGCR(399,IBIFN,"C") K IB3

 Q

 ; Select Diagnosis codes

SELD D S F I=1:1 W ! Q:$Y+10>IOSL

 N IBZ,IBQ

 S IBQ=0

 F I=1:1:5 W !,"DIAGNOSIS CODE (",I,"): " D  Q:IBQ

 . S IBPY=$P(IB("C"),U,(I+13))

 . I IBPY S IBZ=$$ICD9^IBACSV(+IBPY) W $S(IBZ'="":$J($P(IBZ,U),6),1:IBUC)_"// "

 . R X:DTIME I '$T!(X["^")!((X="")&(IBPY="")) S IBQ=1 Q

 . D CHD,S

 Q

CHP N IBDATE,ICDVDT

 I X="?" D 3^IBCSCH1 S I=I-1 Q

 I X="",$P(IB("C"),U,(I+3))]"" Q

 I X["@" W "   ...Deleted" S IB7(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="",$P(IB("C"),U,(I+10))="",IBPX=1 Q

 I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+3))="",$P(^("C"),U,(I+10))="" Q

 I X?1A1N D P^IBCSC4A S IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") S:IB5]"" $P(^DGCR(399,IBIFN,"C"),U,(I+3))=$P(IB5,U,1) D:IB5]"" DT Q:IB5]""  W *7,"  ??" S I=I-1 Q

 I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q

 S:X["?" X="??"

 S IBI=I

 S IBDATE=$P(^DGCR(399,IBIFN,"C"),U,I+10)

 I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN)

 S ICDVDT=IBDATE ; for DD identifier (date of service)

 S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD0ACT^IBACSV(+Y,IBDATE)"

 S DIC="^ICD0(" D DIC I Y'>0 S I=IBI-1 Q

 S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+3))=X D PD

 Q

 ;

CHD N IBDATE,ICDVDT

 I X="?" D 3^IBCSCH1 S I=I-1 Q

 I X="",$P(IB("C"),U,(I+13))]"" Q

 I X["@" W "   ...Deleted" S IB6(I)="",$P(^DGCR(399,IBIFN,"C"),U,(I+13))="",$P(IB("C"),U,(I+13))="",IBPY=1 Q

 I X="" S $P(^DGCR(399,IBIFN,"C"),U,(I+13))="" Q

 I X?1A1N D D^IBCSC4A S IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") S:IB4]"" $P(^DGCR(399,IBIFN,"C"),U,(I+13))=$P(IB4,U,1),IB3=1 Q:IB4]""  W *7,"  ??" S I=I-1 Q

 I $P(^IBE(350.9,1,1),U,15)'=1 D PAR Q

 S:X["?" X="??"

 S IBI=I

 S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service

 S ICDVDT=IBDATE ; For the DD identifier

 S DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD9ACT^IBACSV(+Y,IBDATE)"

 S DIC="^ICD9(" D DIC I Y'>0 S I=IBI-1 Q

 S X=+Y,$P(^DGCR(399,IBIFN,"C"),U,(I+13))=X

 Q

 ;

 ; Check the sex of procedure and the patients

SEXSCR(IBZ,DFN) ;

 N IBCODSEX,IBPTSEX

 S IBCODSEX=$P(IBZ,U,10) ; Sex of the ICD0/ICD9 code, if any

 I IBCODSEX'="M",IBCODSEX'="F" Q 1  ; No assigned sex for the code

 I '$G(DFN) Q 1

 S IBPTSEX=$E($P($G(^DPT(+DFN,0)),U,2)) ; Patient's sex

 I IBPTSEX'="M",IBPTSEX'="F" S IBPTSEX="M" ; Male is default for veterans

 Q IBPTSEX=IBCODSEX

 ;

DT S $P(^DGCR(399,IBIFN,"C"),U,(I+10))=$S($P(IB5,U,2)]"":$P(IB5,U,2),1:$P(^UTILITY($J,"IB",M,1),U,2))

 Q

PAR W:X'["?" "  ??" W !?7,"You may only choose codes found in PTF record!" D 3^IBCSCH1 S I=I-1

 Q

DIC S DIC(0)="EMQ" D ^DIC

 Q

S S:'$D(^DGCR(399,IBIFN,"C")) ^DGCR(399,IBIFN,"C")="" S IB("C")=^DGCR(399,IBIFN,"C")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCSC4C   4438     printed  Mar 13, 2025@21:25:14                                                                                                                                                                                                     Page 2

IBCSC4C   ;ALB/MJB - MCCR PTF SCREEN (CONT.) ;24 FEB 9:43

 +1       ;;2.0;INTEGRATED BILLING;**210,266**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;MAP TO DGCRSC4C

 +5       ;

SETP       if IBP'>2

               SET IB9=0

           DO S

 +1        FOR F=1:1:3

               if IB9=3

                   QUIT 

               IF $DATA(IBWO(F))

                   IF IBWO(F)]""

                       IF $PIECE(IBWO(F),U,1)'=IBNC

                           SET IB9=IB9+1

                           SET IB7(IB9)=IBWO(F)_U_$SELECT($PIECE(IBWO(F),U,2)']"":$PIECE(IBWO(0),U,2),1:"")

 +2        IF '$DATA(IB7(3))

               FOR F=1:1:3

                   if IB9=3

                       QUIT 

                   IF $DATA(IBWE(F))

                       IF IBWE(F)]""

                           IF $PIECE(IBWE(F),U,1)'=IBNC

                               SET IB9=IB9+1

                               SET IB7(IB9)=IBWE(F)_U_$SELECT($PIECE(IBWE(F),U,2)']"":$PIECE(IBWE(0),U,2),1:"")

 +3        if "^^"[$PIECE(IB("C"),U,4,6)!($PIECE(IB("C"),U,4)]"")!($PIECE(IB("C"),U,5)]"")!($PIECE(IB("C"),U,6)]"")

               QUIT 

 +4        FOR F=1:1:3

               IF $DATA(IB7(F))

                   IF $PIECE(^DGCR(399,IBIFN,"C"),U,(F+3))']""

                       SET $PIECE(^DGCR(399,IBIFN,"C"),U,(F+3))=$PIECE(IB7(F),U,1)

                       SET $PIECE(^("C"),U,(F+10))=$PIECE(IB7(F),U,2)

 +5        if $PIECE(^DGCR(399,IBIFN,0),U,9)=""

               SET $PIECE(^DGCR(399,IBIFN,0),U,9)=9

 +6        QUIT 

SETD       if IBDIA'>2

               SET IB8=0

           DO S

 +1        FOR F=1:1:5

               if IB8=5

                   QUIT 

               IF $DATA(IBWO(F))

                   IF IBWO(F)]""

                       IF $PIECE(IBWO(F),U,1)'=IBNC

                           SET IB8=IB8+1

                           SET IB6(IB8)=$PIECE(IBWO(F),U,1)

 +2        IF '$DATA(IB6(5))

               FOR F=1:1:5

                   if IB8=5

                       QUIT 

                   IF $DATA(IBWE(F))

                       IF IBWE(F)]""

                           IF $PIECE(IBWE(F),U,1)'=IBNC

                               SET IB8=IB8+1

                               SET IB6(IB8)=$PIECE(IBWE(F),U,1)

 +3        if "^^^^"[$PIECE(IB("C"),U,14,18)!($PIECE(IB("C"),U,14)]"")!($PIECE(IB("C"),U,15)]"")!($PIECE(IB("C"),U,16)]"")!($PIECE(IB("C"),U,17)]"")!($PIECE(IB("C"),U,18)]"")

               QUIT 

 +4        FOR F=1:1:5

               IF $DATA(IB6(F))

                   SET $PIECE(^DGCR(399,IBIFN,"C"),U,(F+13))=IB6(F)

 +5        QUIT 

SELP       DO S

           FOR I=1:1

               WRITE !

               if $Y+10>IOSL

                   QUIT 

 +1        NEW IBZ,IBQ

 +2       ; Quit flag

           SET IBQ=0

 +3        FOR I=1:1:3

               WRITE !,"ICD PROCEDURE CODE (",I,"): "

               Begin DoDot:1

 +4                SET IBPX=$PIECE(IB("C"),U,(I+3))

 +5                IF IBPX

                       SET IBZ=$$ICD0^IBACSV(+IBPX)

                       WRITE $SELECT(IBZ'="":$JUSTIFY($PIECE(IBZ,U),6),1:IBUC)_"// "

 +6                READ X:DTIME

                   IF '$TEST!(X["^")

                       SET IBQ=1

                       QUIT 

 +7                DO CHP

 +8                IF $DATA(IB3)

                       DO PD

 +9                DO S

               End DoDot:1

               if IBQ

                   QUIT 

 +10       QUIT 

 +11      ;

PD         SET %DT("A")="      PROCEDURE DATE ("_I_"): "

           SET %DT="AEX"

           DO ^%DT

           IF Y>0

               SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+10))=+Y

               SET IB("C")=^DGCR(399,IBIFN,"C")

               KILL IB3

 +1        QUIT 

 +2       ; Select Diagnosis codes

SELD       DO S

           FOR I=1:1

               WRITE !

               if $Y+10>IOSL

                   QUIT 

 +1        NEW IBZ,IBQ

 +2        SET IBQ=0

 +3        FOR I=1:1:5

               WRITE !,"DIAGNOSIS CODE (",I,"): "

               Begin DoDot:1

 +4                SET IBPY=$PIECE(IB("C"),U,(I+13))

 +5                IF IBPY

                       SET IBZ=$$ICD9^IBACSV(+IBPY)

                       WRITE $SELECT(IBZ'="":$JUSTIFY($PIECE(IBZ,U),6),1:IBUC)_"// "

 +6                READ X:DTIME

                   IF '$TEST!(X["^")!((X="")&(IBPY=""))

                       SET IBQ=1

                       QUIT 

 +7                DO CHD

                   DO S

               End DoDot:1

               if IBQ

                   QUIT 

 +8        QUIT 

CHP        NEW IBDATE,ICDVDT

 +1        IF X="?"

               DO 3^IBCSCH1

               SET I=I-1

               QUIT 

 +2        IF X=""

               IF $PIECE(IB("C"),U,(I+3))]""

                   QUIT 

 +3        IF X["@"

               WRITE "   ...Deleted"

               SET IB7(I)=""

               SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=""

               SET $PIECE(^("C"),U,(I+10))=""

               SET $PIECE(IB("C"),U,(I+10))=""

               SET IBPX=1

               QUIT 

 +4        IF X=""

               SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=""

               SET $PIECE(^("C"),U,(I+10))=""

               QUIT 

 +5        IF X?1A1N

               DO P^IBCSC4A

               SET IB5=$SELECT($DATA(^UTILITY($JOB,"IB",M,S)):^(S),1:"")

               if IB5]""

                   SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=$PIECE(IB5,U,1)

               if IB5]""

                   DO DT

               if IB5]""

                   QUIT 

               WRITE *7,"  ??"

               SET I=I-1

               QUIT 

 +6        IF $PIECE(^IBE(350.9,1,1),U,15)'=1

               DO PAR

               QUIT 

 +7        if X["?"

               SET X="??"

 +8        SET IBI=I

 +9        SET IBDATE=$PIECE(^DGCR(399,IBIFN,"C"),U,I+10)

 +10       IF 'IBDATE

               SET IBDATE=$$BDATE^IBACSV(IBIFN)

 +11      ; for DD identifier (date of service)

           SET ICDVDT=IBDATE

 +12       SET DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD0ACT^IBACSV(+Y,IBDATE)"

 +13       SET DIC="^ICD0("

           DO DIC

           IF Y'>0

               SET I=IBI-1

               QUIT 

 +14       SET X=+Y

           SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+3))=X

           DO PD

 +15       QUIT 

 +16      ;

CHD        NEW IBDATE,ICDVDT

 +1        IF X="?"

               DO 3^IBCSCH1

               SET I=I-1

               QUIT 

 +2        IF X=""

               IF $PIECE(IB("C"),U,(I+13))]""

                   QUIT 

 +3        IF X["@"

               WRITE "   ...Deleted"

               SET IB6(I)=""

               SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=""

               SET $PIECE(IB("C"),U,(I+13))=""

               SET IBPY=1

               QUIT 

 +4        IF X=""

               SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=""

               QUIT 

 +5        IF X?1A1N

               DO D^IBCSC4A

               SET IB4=$SELECT($DATA(^UTILITY($JOB,"IBDX",M,S)):^(S),1:"")

               if IB4]""

                   SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=$PIECE(IB4,U,1)

                   SET IB3=1

               if IB4]""

                   QUIT 

               WRITE *7,"  ??"

               SET I=I-1

               QUIT 

 +6        IF $PIECE(^IBE(350.9,1,1),U,15)'=1

               DO PAR

               QUIT 

 +7        if X["?"

               SET X="??"

 +8        SET IBI=I

 +9       ; The date of service

           SET IBDATE=$$BDATE^IBACSV(IBIFN)

 +10      ; For the DD identifier

           SET ICDVDT=IBDATE

 +11       SET DIC("S")="N IBZ S IBZ=$G(^(0)) I $$SEXSCR^IBCSC4C(IBZ,$G(DFN)),$$ICD9ACT^IBACSV(+Y,IBDATE)"

 +12       SET DIC="^ICD9("

           DO DIC

           IF Y'>0

               SET I=IBI-1

               QUIT 

 +13       SET X=+Y

           SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+13))=X

 +14       QUIT 

 +15      ;

 +16      ; Check the sex of procedure and the patients

SEXSCR(IBZ,DFN) ;

 +1        NEW IBCODSEX,IBPTSEX

 +2       ; Sex of the ICD0/ICD9 code, if any

           SET IBCODSEX=$PIECE(IBZ,U,10)

 +3       ; No assigned sex for the code

           IF IBCODSEX'="M"

               IF IBCODSEX'="F"

                   QUIT 1

 +4        IF '$GET(DFN)

               QUIT 1

 +5       ; Patient's sex

           SET IBPTSEX=$EXTRACT($PIECE($GET(^DPT(+DFN,0)),U,2))

 +6       ; Male is default for veterans

           IF IBPTSEX'="M"

               IF IBPTSEX'="F"

                   SET IBPTSEX="M"

 +7        QUIT IBPTSEX=IBCODSEX

 +8       ;

DT         SET $PIECE(^DGCR(399,IBIFN,"C"),U,(I+10))=$SELECT($PIECE(IB5,U,2)]"":$PIECE(IB5,U,2),1:$PIECE(^UTILITY($JOB,"IB",M,1),U,2))

 +1        QUIT 

PAR        if X'["?"

               WRITE "  ??"

           WRITE !?7,"You may only choose codes found in PTF record!"

           DO 3^IBCSCH1

           SET I=I-1

 +1        QUIT 

DIC        SET DIC(0)="EMQ"

           DO ^DIC

 +1        QUIT 

S          if '$DATA(^DGCR(399,IBIFN,"C"))

               SET ^DGCR(399,IBIFN,"C")=""

           SET IB("C")=^DGCR(399,IBIFN,"C")

 +1        QUIT