- 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
