Routine: IBCD4

IBCD4 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - GATHER DX AND PROCEDURES)  ;9/5/93

 ;;2.0;INTEGRATED BILLING;**14,80,106,160,309,276,347,522**;21-MAR-94;Build 11

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

IDX(PTF,DT1,DT2) ; find 501 movement Diagnosis and 701 Discharge Diagnosisfor a PTF record within bill range

 ; check for billable bedsection and SC treatement and duplicates

 ; results: IBT = number of billable movements within date range

 ;          IBMSG(X)=" error message " if any errors found

 ;         ^TMP("IBDX",$J) = PTF IFN

 ;         ^TMP("IBDX",$J,"DX",DX) = MOVE DATE/TIME ^ MOVE IEN ^ POA

 ;         ^TMP("IBDX",$J,-MOVE DATE/TIME, MOVE IEN) = Dx ^ ^ POA

 N IBMVT,IBN,IBDT,IBCNT,IBBS,IBSC,IBMV,IBDX,IBI,IBX K IBMSG,IBT,^TMP("IBDX",$J)

 D PTFDXDT^IBCSC4F(PTF,DT1,DT2) S IBMVT="M" I +$P($G(^TMP($J,"IBDX","D")),U,3) S IBMVT="D"

 S ^TMP("IBDX",$J)=+PTF S (IBT,IBBS,IBSC)=0,IBCNT=1

 F IBN="D","M" S IBDT="" F  S IBDT=$O(^TMP($J,"IBDX",IBN,IBDT)) Q:'IBDT  D

 . S IBMV=$G(^TMP($J,"IBDX",IBN,IBDT)) Q:IBMV=""

. ;

 . I IBN="M" S IBT=IBT+1,IBX="" D  Q:+IBX

 .. I $P(IBMV,U,3)=1 S IBSC=IBSC+1,IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement related to an SC condition.",IBCNT=IBCNT+1,IBX=1

 .. I $P($G(^DIC(42.4,+$P(IBMV,U,2),0)),U,5)="" S IBBS=IBBS+1,IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement is for a non-billable bedsection.",IBCNT=IBCNT+1,IBX=1

 .. I '$P(IBMV,U,4) S IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement does not have a DRG as required for Reasonable Charges.",IBCNT=IBCNT+1

 . I IBN'=IBMVT Q

. ;

 . S IBI="" F  S IBI=$O(^TMP($J,"IBDX",IBN,IBDT,IBI)) Q:'IBI  D

 .. S IBDX=$G(^TMP($J,"IBDX",IBN,IBDT,IBI)) Q:'IBDX

 .. I '$P(IBDX,U,2),IBDT>+$G(^TMP("IBDX",$J,"DX",+IBDX)) S ^TMP("IBDX",$J,"DX",+IBDX)=IBDT_U_IBI_U_$P(IBDX,U,3)

 S IBDX="" F  S IBDX=$O(^TMP("IBDX",$J,"DX",IBDX)) Q:'IBDX  D

 . S IBX=^TMP("IBDX",$J,"DX",IBDX) I +IBX S ^TMP("IBDX",$J,-IBX,+$P(IBX,U,2))=IBDX_U_U_$P(IBX,U,3)

 K ^TMP($J,"IBDX")

 I +IBSC S IBMSG(IBCNT)="PTF record indicates "_+IBSC_" of "_IBT_" movements are for Service Connected Care.",IBCNT=IBCNT+1

 I +IBBS S IBMSG(IBCNT)="PTF record indicates "_+IBBS_" of "_IBT_" movements are for a non-billable bedsection.",IBCNT=IBCNT+1

 S IBT=IBT-IBSC-IBBS I 'IBT S IBMSG(IBCNT)="0 movements are billable."

IDXE Q

RXRF(PIFN,RIFN,IBDT) ; returns data on fill on date for rx (RX # ^ DRUG ^ DAYS SUPPLY ^ FILL DATE ^ QTY ^ NDC #)

 N X,Y,PLN,RLN,IBFILL,PDFN,LIST,NODE

 S X=""

 S PDFN=$$FILE^IBRXUTL(PIFN,2)

 S LIST="IBRXARR"

 S NODE="R^^"

 I +$G(PIFN) S PLN=$$RXZERO^IBRXUTL(PDFN,PIFN) I PLN'="" D

 . D RX^PSO52API(PDFN,LIST,PIFN,,NODE,,)

 . I $G(IBDT) D REF^PSO52EX($G(IBDT),$G(IBDT),LIST) S RIFN=$O(^TMP($J,LIST,"AD",IBDT,PIFN,""))

 . S RLN="",IBFILL="^^" I $G(RIFN)="" S X="" Q

 . I (RIFN=0)!(RIFN=-1) S RLN=$$RXSEC^IBRXUTL(PDFN,PIFN) Q:RLN=""  S IBFILL=$P(PLN,U,8)_"^"_$P(RLN,U,2)_"^"_$P(PLN,U,7)

 . I RIFN>0 S RLN=$$ZEROSUB^IBRXUTL(PDFN,PIFN,RIFN) Q:RLN=""  S IBFILL=$P(RLN,U,10)_"^"_$P(RLN,U,1)_"^"_$P(RLN,U,4)

 . S X=$P(PLN,U,1)_"^"_$P(PLN,U,6)_"^"_IBFILL_"^"_$$GETNDC^PSONDCUT(+PIFN,+RIFN)

 E  S X=""

 K ^TMP($J,LIST)

Q X

CHK() ;other checks

 N X S X=1 I $G(^DPT(+$G(IBDFN),0))="" S X="0^Patient information lacking."

Q X

CHKSYS() ;various checks to determine if bill can be created, returns true if passes   XXXXXX

 ;if fails then returns "0^error message"

 ;requires nothing

 N X,Y,I S X=1

 I '$P($G(^IBE(350.9,1,1)),U,14) S X="0^MAS SERVICE PARAMETER UNKNOWN" G CHKSYSE

 I +$P($$SITE^VASITE,U,3)<1 S X="0^ACILITY UNDEFINED" G CHKSYSE

 ;G:$D(IBB) CHKSYSE

 ;I '$D(DUZ(0)) S X="0^FILEMAN ACCESS UNDEFINED" G CHKSYSE

 ;I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO"))  S DLAYGO=399

CHKSYSE Q X

 ;GVARS(IFN) ;get data on bill IFN  (commented out patch 80, does not appear to be used)

 ;N I S X=1 I '$G(^DGCR(399,+$G(IFN),0)) S X=0 G GVARSE

 ;F I=0,"M" S IB(I)=$G(^DGCR(399,+IFN,I))

 ;S DGINPAR=$P($G(^DIC(36,+IB("MP"),0)),U,6,10)

 ;GVARSE Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCD4   4037     printed  Mar 13, 2025@21:14:05                                                                                                                                                                                                       Page 2

IBCD4     ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - GATHER DX AND PROCEDURES)  ;9/5/93

 +1       ;;2.0;INTEGRATED BILLING;**14,80,106,160,309,276,347,522**;21-MAR-94;Build 11

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

 +3       ;

 +4       ;

IDX(PTF,DT1,DT2) ; find 501 movement Diagnosis and 701 Discharge Diagnosisfor a PTF record within bill range

 +1       ; check for billable bedsection and SC treatement and duplicates

 +2       ; results: IBT = number of billable movements within date range

 +3       ;          IBMSG(X)=" error message " if any errors found

 +4       ;         ^TMP("IBDX",$J) = PTF IFN

 +5       ;         ^TMP("IBDX",$J,"DX",DX) = MOVE DATE/TIME ^ MOVE IEN ^ POA

 +6       ;         ^TMP("IBDX",$J,-MOVE DATE/TIME, MOVE IEN) = Dx ^ ^ POA

 +7        NEW IBMVT,IBN,IBDT,IBCNT,IBBS,IBSC,IBMV,IBDX,IBI,IBX

           KILL IBMSG,IBT,^TMP("IBDX",$JOB)

 +8       ;

 +9        DO PTFDXDT^IBCSC4F(PTF,DT1,DT2)

           SET IBMVT="M"

           IF +$PIECE($GET(^TMP($JOB,"IBDX","D")),U,3)

               SET IBMVT="D"

 +10      ;

 +11       SET ^TMP("IBDX",$JOB)=+PTF

           SET (IBT,IBBS,IBSC)=0

           SET IBCNT=1

 +12       FOR IBN="D","M"

               SET IBDT=""

FOR

                   SET IBDT=$ORDER(^TMP($JOB,"IBDX",IBN,IBDT))

                   if 'IBDT

                       QUIT

                   Begin DoDot:1

 +13                   SET IBMV=$GET(^TMP($JOB,"IBDX",IBN,IBDT))

                       if IBMV=""

                           QUIT

 +14      ;

 +15                   IF IBN="M"

                           SET IBT=IBT+1

                           SET IBX=""

                           Begin DoDot:2

 +16                           IF $PIECE(IBMV,U,3)=1

                                   SET IBSC=IBSC+1

                                   SET IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement related to an SC condition."

                                   SET IBCNT=IBCNT+1

                                   SET IBX=1

 +17                           IF $PIECE($GET(^DIC(42.4,+$PIECE(IBMV,U,2),0)),U,5)=""

                                   SET IBBS=IBBS+1

                                   SET IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement is for a non-billable bedsection."

                                   SET IBCNT=IBCNT+1

                                   SET IBX=1

 +18                           IF '$PIECE(IBMV,U,4)

                                   SET IBMSG(IBCNT)=$$FMTE^XLFDT(IBDT)_" movement does not have a DRG as required for Reasonable Charges."

                                   SET IBCNT=IBCNT+1

                           End DoDot:2

                           if +IBX

                               QUIT

 +19                   IF IBN'=IBMVT

                           QUIT

 +20      ;

 +21                   SET IBI=""

FOR

                           SET IBI=$ORDER(^TMP($JOB,"IBDX",IBN,IBDT,IBI))

                           if 'IBI

                               QUIT

                           Begin DoDot:2

 +22                           SET IBDX=$GET(^TMP($JOB,"IBDX",IBN,IBDT,IBI))

                               if 'IBDX

                                   QUIT

 +23                           IF '$PIECE(IBDX,U,2)

                                   IF IBDT>+$GET(^TMP("IBDX",$JOB,"DX",+IBDX))

                                       SET ^TMP("IBDX",$JOB,"DX",+IBDX)=IBDT_U_IBI_U_$PIECE(IBDX,U,3)

                           End DoDot:2

                   End DoDot:1

 +24      ;

 +25       SET IBDX=""

FOR

               SET IBDX=$ORDER(^TMP("IBDX",$JOB,"DX",IBDX))

               if 'IBDX

                   QUIT

               Begin DoDot:1

 +26               SET IBX=^TMP("IBDX",$JOB,"DX",IBDX)

                   IF +IBX

                       SET ^TMP("IBDX",$JOB,-IBX,+$PIECE(IBX,U,2))=IBDX_U_U_$PIECE(IBX,U,3)

               End DoDot:1

 +27       KILL ^TMP($JOB,"IBDX")

 +28      ;

 +29       IF +IBSC

               SET IBMSG(IBCNT)="PTF record indicates "_+IBSC_" of "_IBT_" movements are for Service Connected Care."

               SET IBCNT=IBCNT+1

 +30       IF +IBBS

               SET IBMSG(IBCNT)="PTF record indicates "_+IBBS_" of "_IBT_" movements are for a non-billable bedsection."

               SET IBCNT=IBCNT+1

 +31       SET IBT=IBT-IBSC-IBBS

           IF 'IBT

               SET IBMSG(IBCNT)="0 movements are billable."

IDXE       QUIT

 +1       ;

RXRF(PIFN,RIFN,IBDT) ; returns data on fill on date for rx (RX # ^ DRUG ^ DAYS SUPPLY ^ FILL DATE ^ QTY ^ NDC #)

 +1        NEW X,Y,PLN,RLN,IBFILL,PDFN,LIST,NODE

 +2        SET X=""

 +3        SET PDFN=$$FILE^IBRXUTL(PIFN,2)

 +4        SET LIST="IBRXARR"

 +5        SET NODE="R^^"

 +6        IF +$GET(PIFN)

               SET PLN=$$RXZERO^IBRXUTL(PDFN,PIFN)

               IF PLN'=""

                   Begin DoDot:1

 +7                    DO RX^PSO52API(PDFN,LIST,PIFN,,NODE,,)

 +8                    IF $GET(IBDT)

                           DO REF^PSO52EX($GET(IBDT),$GET(IBDT),LIST)

                           SET RIFN=$ORDER(^TMP($JOB,LIST,"AD",IBDT,PIFN,""))

 +9                    SET RLN=""

                       SET IBFILL="^^"

                       IF $GET(RIFN)=""

                           SET X=""

                           QUIT

 +10                   IF (RIFN=0)!(RIFN=-1)

                           SET RLN=$$RXSEC^IBRXUTL(PDFN,PIFN)

                           if RLN=""

                               QUIT

                           SET IBFILL=$PIECE(PLN,U,8)_"^"_$PIECE(RLN,U,2)_"^"_$PIECE(PLN,U,7)

 +11                   IF RIFN>0

                           SET RLN=$$ZEROSUB^IBRXUTL(PDFN,PIFN,RIFN)

                           if RLN=""

                               QUIT

                           SET IBFILL=$PIECE(RLN,U,10)_"^"_$PIECE(RLN,U,1)_"^"_$PIECE(RLN,U,4)

 +12                   SET X=$PIECE(PLN,U,1)_"^"_$PIECE(PLN,U,6)_"^"_IBFILL_"^"_$$GETNDC^PSONDCUT(+PIFN,+RIFN)

                   End DoDot:1

 +13      IF '$TEST

               SET X=""

 +14       KILL ^TMP($JOB,LIST)

 +15       QUIT X

 +16      ;

CHK()     ;other checks

 +1        NEW X

           SET X=1

           IF $GET(^DPT(+$GET(IBDFN),0))=""

               SET X="0^Patient information lacking."

 +2        QUIT X

 +3       ;

CHKSYS()  ;various checks to determine if bill can be created, returns true if passes   XXXXXX

 +1       ;if fails then returns "0^error message"

 +2       ;requires nothing

 +3        NEW X,Y,I

           SET X=1

 +4        IF '$PIECE($GET(^IBE(350.9,1,1)),U,14)

               SET X="0^MAS SERVICE PARAMETER UNKNOWN"

               GOTO CHKSYSE

 +5        IF +$PIECE($$SITE^VASITE,U,3)<1

               SET X="0^ACILITY UNDEFINED"

               GOTO CHKSYSE

 +6       ;G:$D(IBB) CHKSYSE

 +7       ;I '$D(DUZ(0)) S X="0^FILEMAN ACCESS UNDEFINED" G CHKSYSE

 +8       ;I $S($D(DLAYGO):2\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(399,0,"LAYGO"))  S DLAYGO=399

CHKSYSE    QUIT X

 +1       ;

 +2       ;GVARS(IFN) ;get data on bill IFN  (commented out patch 80, does not appear to be used)

 +3       ;N I S X=1 I '$G(^DGCR(399,+$G(IFN),0)) S X=0 G GVARSE

 +4       ;F I=0,"M" S IB(I)=$G(^DGCR(399,+IFN,I))

 +5       ;S DGINPAR=$P($G(^DIC(36,+IB("MP"),0)),U,6,10)

 +6       ;GVARSE Q X

IBCD4.m