IBCF331.m

IBCF331	;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993

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

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

	;

	;

DX	;additional dx codes (ie more than 9 on bill)

	D SET^IBCSC4D(IBIFN,"",.IBARRAY) G:$P(IBARRAY,U,2)'>9 RX

	S IBX=+$P(IBARRAY,U,2)-9+2 D SPACE

	S IBZ="" D SET2

	S IBZ="ADDITIONAL DIAGNOSIS CODES:" D SET2

	S (IBI,IBX)=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX=""  I IBI>9 D

	. S IBY=+IBARRAY(IBX),IBY=$G(^ICD9(IBY,0)) Q:IBY=""

	. S IBZ=$P(IBY,U,1)_$J(" ",(10-$L($P(IBY,U,1))))_$P(IBY,U,3) D SET2

	;

RX	;add rx refills

	D SET^IBCSC5A(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) PD

	S IBX=+$P(IBARRAY,U,2)+2 D SPACE

	S IBZ="" D SET2

	S IBZ="PRESCRIPTION REFILLS:" D SET2

	S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  S IBLN=IBARRAY(IBX,IBY) D

	. S IBZ=IBX_$J(" ",(20-$L(IBX)))_$$FMTE^XLFDT(IBY)_"  "_$P($G(^PSDRUG(+$P(IBLN,U,2),0)),U,1) D SET2

	. S IBZ="",IBZ=$S(+$P(IBLN,U,4):"QTY: "_$P(IBLN,U,4)_" ",1:"")_$S(+$P(IBLN,U,3):"for "_$P(IBLN,U,3)_" days supply ",1:"") I IBZ'="" S IBZ=$J(" ",34)_IBZ D SET2

	. S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",34)_IBZ D SET2

	;

PD	;add prosthetic items

	D SET^IBCSC5B(IBIFN,.IBARRAY) G:'$P(IBARRAY,U,2) END

	S IBX=+$P(IBARRAY,U,2)+2 D SPACE

	S IBZ="" D SET2

	S IBZ="PROSTHETIC ITEMS:" D SET2

	S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D

	. S IBZ=$$FMTE^XLFDT(IBX)_"  "_$P($$PIN^IBCSC5B(IBY),U,2) D SET2

	;

END	Q

	;

SET2	D SET2^IBCF33 Q

SPACE	D SPACE^IBCF33 Q

IBCF331   ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993

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

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

 +3       ;

 +4       ;

DX        ;additional dx codes (ie more than 9 on bill)

 +1        DO SET^IBCSC4D(IBIFN,"",.IBARRAY)

           IF $PIECE(IBARRAY,U,2)'>9

               GOTO RX

 +2        SET IBX=+$PIECE(IBARRAY,U,2)-9+2

           DO SPACE

 +3        SET IBZ=""

           DO SET2

 +4        SET IBZ="ADDITIONAL DIAGNOSIS CODES:"

           DO SET2

 +5        SET (IBI,IBX)=0

           FOR IBI=1:1

               SET IBX=$ORDER(IBARRAY(IBX))

               IF IBX=""

                   QUIT 

               IF IBI>9

                   Begin DoDot:1

 +6                    SET IBY=+IBARRAY(IBX)

                       SET IBY=$GET(^ICD9(IBY,0))

                       IF IBY=""

                           QUIT 

 +7                    SET IBZ=$PIECE(IBY,U,1)_$JUSTIFY(" ",(10-$LENGTH($PIECE(IBY,U,1))))_$PIECE(IBY,U,3)

                       DO SET2

                   End DoDot:1

 +8       ;

RX        ;add rx refills

 +1        DO SET^IBCSC5A(IBIFN,.IBARRAY)

           IF '$PIECE(IBARRAY,U,2)

               GOTO PD

 +2        SET IBX=+$PIECE(IBARRAY,U,2)+2

           DO SPACE

 +3        SET IBZ=""

           DO SET2

 +4        SET IBZ="PRESCRIPTION REFILLS:"

           DO SET2

 +5        SET IBX=0

           FOR 

               SET IBX=$ORDER(IBARRAY(IBX))

               IF IBX=""

                   QUIT 

               SET IBY=0

               FOR 

                   SET IBY=$ORDER(IBARRAY(IBX,IBY))

                   IF 'IBY

                       QUIT 

                   SET IBLN=IBARRAY(IBX,IBY)

                   Begin DoDot:1

 +6                    SET IBZ=IBX_$JUSTIFY(" ",(20-$LENGTH(IBX)))_$$FMTE^XLFDT(IBY)_"  "_$PIECE($GET(^PSDRUG(+$PIECE(IBLN,U,2),0)),U,1)

                       DO SET2

 +7                    SET IBZ=""

                       SET IBZ=$SELECT(+$PIECE(IBLN,U,4):"QTY: "_$PIECE(IBLN,U,4)_" ",1:"")_$SELECT(+$PIECE(IBLN,U,3):"for "_$PIECE(IBLN,U,3)_" days supply ",1:"")

                       IF IBZ'=""

                           SET IBZ=$JUSTIFY(" ",34)_IBZ

                           DO SET2

 +8                    SET IBZ=""

                       SET IBZ=$SELECT($PIECE(IBLN,U,5)'="":"NDC #: "_$PIECE(IBLN,U,5),1:"")

                       IF IBZ'=""

                           SET IBZ=$JUSTIFY(" ",34)_IBZ

                           DO SET2

                   End DoDot:1

 +9       ;

PD        ;add prosthetic items

 +1        DO SET^IBCSC5B(IBIFN,.IBARRAY)

           IF '$PIECE(IBARRAY,U,2)

               GOTO END

 +2        SET IBX=+$PIECE(IBARRAY,U,2)+2

           DO SPACE

 +3        SET IBZ=""

           DO SET2

 +4        SET IBZ="PROSTHETIC ITEMS:"

           DO SET2

 +5        SET IBX=0

           FOR 

               SET IBX=$ORDER(IBARRAY(IBX))

               IF IBX=""

                   QUIT 

               SET IBY=0

               FOR 

                   SET IBY=$ORDER(IBARRAY(IBX,IBY))

                   IF 'IBY

                       QUIT 

                   Begin DoDot:1

 +6                    SET IBZ=$$FMTE^XLFDT(IBX)_"  "_$PIECE($$PIN^IBCSC5B(IBY),U,2)

                       DO SET2

                   End DoDot:1

 +7       ;

END        QUIT 

 +1       ;

SET2       DO SET2^IBCF33

           QUIT 

SPACE      DO SPACE^IBCF33

           QUIT