IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6
;;Per VHA Directive 2004-038, 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 IBX=0 F IBI=1:1 S IBX=$O(IBARRAY(IBX)) Q:IBX="" I IBI>9 D
. S IBY=$$ICD9^IBACSV(+$G(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN)) Q:IBY=""
. S IBZ=$P(IBY,U)_$J(" ",(10-$L($P(IBY,U))))_$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
. D ZERO^IBRXUTL(+$P(IBLN,U,2))
. S IBZ=IBX_$J(" ",(11-$L(IBX)))_" "_$J($S($P(IBLN,U,6):"$"_$FN($P(IBLN,U,6),",",2),1:""),10)_" "_$J($$FMTE^XLFDT(IBY,2),8)_" "_$G(^TMP($J,"IBDRUG",+$P(IBLN,U,2),.01)) 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(" ",35)_IBZ D SET2
. S IBZ="",IBZ=$S($P(IBLN,U,5)'="":"NDC #: "_$P(IBLN,U,5),1:"") I IBZ'="" S IBZ=$J(" ",35)_IBZ D SET2
. K ^TMP($J,"IBDRUG")
. Q
;
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,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) D SET2
;
END Q
;
SET2 D SET2^IBCF33 Q
SPACE D SPACE^IBCF33 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF331 1918 printed Dec 13, 2024@02:13:01 Page 2
IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
+1 ;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, 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 IBX=0
FOR IBI=1:1
SET IBX=$ORDER(IBARRAY(IBX))
if IBX=""
QUIT
IF IBI>9
Begin DoDot:1
+6 SET IBY=$$ICD9^IBACSV(+$GET(IBARRAY(IBX)),$$BDATE^IBACSV(+IBIFN))
if IBY=""
QUIT
+7 SET IBZ=$PIECE(IBY,U)_$JUSTIFY(" ",(10-$LENGTH($PIECE(IBY,U))))_$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 DO ZERO^IBRXUTL(+$PIECE(IBLN,U,2))
+7 SET IBZ=IBX_$JUSTIFY(" ",(11-$LENGTH(IBX)))_" "_$JUSTIFY($SELECT($PIECE(IBLN,U,6):"$"_$FNUMBER($PIECE(IBLN,U,6),",",2),1:""),10)_" "_$JUSTIFY($$FMTE^XLFDT(IBY,2),8)_" "_$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBLN,U,2),.01))
DO SET2
+8 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(" ",35)_IBZ
DO SET2
+9 SET IBZ=""
SET IBZ=$SELECT($PIECE(IBLN,U,5)'="":"NDC #: "_$PIECE(IBLN,U,5),1:"")
IF IBZ'=""
SET IBZ=$JUSTIFY(" ",35)_IBZ
DO SET2
+10 KILL ^TMP($JOB,"IBDRUG")
+11 QUIT
End DoDot:1
+12 ;
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,2)_" "_$JUSTIFY($SELECT($PIECE(IBARRAY(IBX,IBY),U,2):"$"_$FNUMBER($PIECE(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_" "_$EXTRACT($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)
DO SET2
End DoDot:1
+7 ;
END QUIT
+1 ;
SET2 DO SET2^IBCF33
QUIT
SPACE DO SPACE^IBCF33
QUIT
