Routine: IBCD4

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

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

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

IDX(PTF,DT1,DT2)	;find all 501 movement Diagnosis' for PTF record, check for billable bedsection and SC treatement

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

	;         ^TMP("IBDX",$J)= PTF IFN, ^TMP("IBDX",$J,DX)="",IBMSG(X)=" error message "

	;where DX = file 45, fields 45.02: 5-9

	N IBMDT,IBDA,IBI,IBX,IBY,IBZ K IBMSG,IBT,^TMP("IBDX",$J) I '$D(^DGPT(+$G(PTF),"M")) G IDXE

	;get next movement after begin date: each movement entry contains data for the previous date range

	S (DT1,IBX)=+$G(DT1)\1 I +$P($G(^DGPT(+PTF,0)),U,2)\1'=DT1 D  ;use all moves on admit date

	. S IBX=$O(^DGPT(+PTF,"M","AM",IBX-.00001)) S:(IBX\1)=DT1 IBX=IBX+.0001 S DT1=$S(+IBX:+IBX,1:+DT1) ;skip first move on begin date

	;get next movement after end date, use all moves on end date

	S DT2=$S(+$G(DT2):DT2\1-.00001,1:DT),IBX=$O(^DGPT(+PTF,"M","AM",DT2)),DT2=$S('IBX:DT+.99,(IBX\1)=DT2:DT2+.6,1:IBX)

	S ^TMP("IBDX",$J)=+PTF

	S (IBT,IBBS,IBSC,IBDA)=0,IBCNT=1 F  S IBDA=$O(^DGPT(+PTF,"M",IBDA)) Q:'IBDA  D

	. S IBX=$G(^DGPT(+PTF,"M",IBDA,0)) Q:IBX=""  S IBMDT=+$P(IBX,U,10) S:'IBMDT IBMDT=DT I IBMDT<DT1!(IBMDT>DT2) Q

	. S IBT=IBT+1 I $P(IBX,U,18)=1 S IBSC=IBSC+1,IBMSG(IBCNT)=$$FMTE^XLFDT(IBMDT)_" movement related to an SC condition.",IBCNT=IBCNT+1 Q

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

	. S IBZ="" F IBI=5:1:9 S IBY=$P(IBX,U,IBI) I +IBY S ^TMP("IBDX",$J,IBY)=""

	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

IPRC(PTF,DT1,DT2)	;find 401 and 601 procedures for a PTF record

	;results: ^TMP("IBIPRC",$J,PROC DATE)=PROC1^ ... ^PROC5

	;where PROC DATE = (45.01,45.01,.01) and (45,45.05,.01) and PROC = (45,45.01,8-12) and (45,45.05,4-8)

	N IBX,IBY,IBZ,IBI K ^TMP("IBIPRC",$J) I '$D(^DGPT(+$G(PTF),0)) G IPRCE

	S DT1=$S(+$G(DT1):+DT1,1:0),DT2=$S(+$G(DT2):+DT2,1:9999999),^TMP("IBIPRC",$J)=+PTF

	S IBX=0 F  S IBX=$O(^DGPT(+PTF,"S",IBX)) Q:'IBX  S IBY=$G(^DGPT(+PTF,"S",IBX,0)) I +IBY'<DT1,+IBY'>DT2 D

	. S IBZ="" F IBI=8:1:12 I +$P(IBY,U,IBI) S IBZ=IBZ_+$P(IBY,U,IBI)_U

	. I +IBZ S ^TMP("IBIPRC",$J,+IBY)=$G(^TMP("IBIPRC",$J,+IBY))_IBZ

	S IBX=0 F  S IBX=$O(^DGPT(+PTF,"P",IBX)) Q:'IBX  S IBY=$G(^DGPT(+PTF,"P",IBX,0)) I +IBY'<DT1,+IBY'>DT2 D

	. S IBZ="" F IBI=5:1:9 I +$P(IBY,U,IBI) S IBZ=IBZ_+$P(IBY,U,IBI)_U

	. I +IBZ S ^TMP("IBIPRC",$J,+IBY)=$G(^TMP("IBIPRC",$J,+IBY))_IBZ

IPRCE	Q

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

	N X,Y,PLN S X="",PLN=$G(^PSRX(+$G(PIFN),0)) I PLN'="" D

	. S RIFN=$G(RIFN) S:'RIFN RIFN=$O(^PSRX(+$G(PIFN),1,"B",+$G(IBDT),0)) S RLN=$G(^PSRX(+$G(PIFN),1,+RIFN,0)) Q:RLN=""

	. S X=$P(PLN,U,1)_"^"_$P(PLN,U,6)_"^"_$P(PLN,U,8)_"^"_$P(RLN,U,1)_"^"_$P(RLN,U,4)_"^"_$P($G(^PSDRUG(+$P(PLN,U,6),2)),U,4)

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

	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("M"),0)),U,6,10)

GVARSE	Q X

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

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

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

 +3       ;

 +4       ;

IDX(PTF,DT1,DT2) ;find all 501 movement Diagnosis' for PTF record, check for billable bedsection and SC treatement

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

 +2       ;         ^TMP("IBDX",$J)= PTF IFN, ^TMP("IBDX",$J,DX)="",IBMSG(X)=" error message "

 +3       ;where DX = file 45, fields 45.02: 5-9

 +4        NEW IBMDT,IBDA,IBI,IBX,IBY,IBZ

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

           IF '$DATA(^DGPT(+$GET(PTF),"M"))

               GOTO IDXE

 +5       ;get next movement after begin date: each movement entry contains data for the previous date range

 +6       ;use all moves on admit date

           SET (DT1,IBX)=+$GET(DT1)\1

           IF +$PIECE($GET(^DGPT(+PTF,0)),U,2)\1'=DT1

               Begin DoDot:1

 +7       ;skip first move on begin date

                   SET IBX=$ORDER(^DGPT(+PTF,"M","AM",IBX-.00001))

                   IF (IBX\1)=DT1

                       SET IBX=IBX+.0001

                   SET DT1=$SELECT(+IBX:+IBX,1:+DT1)

               End DoDot:1

 +8       ;get next movement after end date, use all moves on end date

 +9        SET DT2=$SELECT(+$GET(DT2):DT2\1-.00001,1:DT)

           SET IBX=$ORDER(^DGPT(+PTF,"M","AM",DT2))

           SET DT2=$SELECT('IBX:DT+.99,(IBX\1)=DT2:DT2+.6,1:IBX)

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

 +11       SET (IBT,IBBS,IBSC,IBDA)=0

           SET IBCNT=1

FOR

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

               IF 'IBDA

                   QUIT

               Begin DoDot:1

 +12               SET IBX=$GET(^DGPT(+PTF,"M",IBDA,0))

                   IF IBX=""

                       QUIT

                   SET IBMDT=+$PIECE(IBX,U,10)

                   IF 'IBMDT

                       SET IBMDT=DT

                   IF IBMDT<DT1!(IBMDT>DT2)

                       QUIT

 +13               SET IBT=IBT+1

                   IF $PIECE(IBX,U,18)=1

                       SET IBSC=IBSC+1

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

                       SET IBCNT=IBCNT+1

                       QUIT

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

                       SET IBBS=IBBS+1

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

                       SET IBCNT=IBCNT+1

                       QUIT

 +15               SET IBZ=""

                   FOR IBI=5:1:9

                       SET IBY=$PIECE(IBX,U,IBI)

                       IF +IBY

                           SET ^TMP("IBDX",$JOB,IBY)=""

               End DoDot:1

 +16       IF +IBSC

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

               SET IBCNT=IBCNT+1

 +17       IF +IBBS

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

               SET IBCNT=IBCNT+1

 +18       SET IBT=IBT-IBSC-IBBS

           IF 'IBT

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

IDXE       QUIT

 +1       ;

IPRC(PTF,DT1,DT2) ;find 401 and 601 procedures for a PTF record

 +1       ;results: ^TMP("IBIPRC",$J,PROC DATE)=PROC1^ ... ^PROC5

 +2       ;where PROC DATE = (45.01,45.01,.01) and (45,45.05,.01) and PROC = (45,45.01,8-12) and (45,45.05,4-8)

 +3        NEW IBX,IBY,IBZ,IBI

           KILL ^TMP("IBIPRC",$JOB)

           IF '$DATA(^DGPT(+$GET(PTF),0))

               GOTO IPRCE

 +4        SET DT1=$SELECT(+$GET(DT1):+DT1,1:0)

           SET DT2=$SELECT(+$GET(DT2):+DT2,1:9999999)

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

 +5        SET IBX=0

FOR

               SET IBX=$ORDER(^DGPT(+PTF,"S",IBX))

               IF 'IBX

                   QUIT

               SET IBY=$GET(^DGPT(+PTF,"S",IBX,0))

               IF +IBY'<DT1

                   IF +IBY'>DT2

                       Begin DoDot:1

 +6                        SET IBZ=""

                           FOR IBI=8:1:12

                               IF +$PIECE(IBY,U,IBI)

                                   SET IBZ=IBZ_+$PIECE(IBY,U,IBI)_U

 +7                        IF +IBZ

                               SET ^TMP("IBIPRC",$JOB,+IBY)=$GET(^TMP("IBIPRC",$JOB,+IBY))_IBZ

                       End DoDot:1

 +8        SET IBX=0

FOR

               SET IBX=$ORDER(^DGPT(+PTF,"P",IBX))

               IF 'IBX

                   QUIT

               SET IBY=$GET(^DGPT(+PTF,"P",IBX,0))

               IF +IBY'<DT1

                   IF +IBY'>DT2

                       Begin DoDot:1

 +9                        SET IBZ=""

                           FOR IBI=5:1:9

                               IF +$PIECE(IBY,U,IBI)

                                   SET IBZ=IBZ_+$PIECE(IBY,U,IBI)_U

 +10                       IF +IBZ

                               SET ^TMP("IBIPRC",$JOB,+IBY)=$GET(^TMP("IBIPRC",$JOB,+IBY))_IBZ

                       End DoDot:1

IPRCE      QUIT

 +1       ;

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

 +1        NEW X,Y,PLN

           SET X=""

           SET PLN=$GET(^PSRX(+$GET(PIFN),0))

           IF PLN'=""

               Begin DoDot:1

 +2                SET RIFN=$GET(RIFN)

                   IF 'RIFN

                       SET RIFN=$ORDER(^PSRX(+$GET(PIFN),1,"B",+$GET(IBDT),0))

                   SET RLN=$GET(^PSRX(+$GET(PIFN),1,+RIFN,0))

                   IF RLN=""

                       QUIT

 +3                SET X=$PIECE(PLN,U,1)_"^"_$PIECE(PLN,U,6)_"^"_$PIECE(PLN,U,8)_"^"_$PIECE(RLN,U,1)_"^"_$PIECE(RLN,U,4)_"^"_$PIECE($GET(^PSDRUG(+$PIECE(PLN,U,6),2)),U,4)

               End DoDot:1

 +4        QUIT X

 +5       ;

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       ;

GVARS(IFN) ;get data on bill IFN

 +1        NEW I

           SET X=1

           IF '$GET(^DGCR(399,+$GET(IFN),0))

               SET X=0

               GOTO GVARSE

 +2        FOR I=0,"M"

               SET IB(I)=$GET(^DGCR(399,+IFN,I))

 +3        SET DGINPAR=$PIECE($GET(^DIC(36,+IB("M"),0)),U,6,10)

GVARSE     QUIT X

IBCD4.m