IBJTBC ;ALB/ARH - TPI BILL PROCEDURES SCREEN ;02-MAR-1995
;;2.0;INTEGRATED BILLING;**39,80,51,137,210,349,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; -- main entry point for IBJ TP BILL PROCEDURES
D EN^VALM("IBJT BILL PROCEDURES")
Q
;
HDR ; -- header code
D HDR^IBJTU1(+IBIFN,+DFN,12)
Q
;
INIT ; -- init variables and list array
K ^TMP("IBJTBC",$J) N IBFT
I '$G(DFN)!'$G(IBIFN) S VALMQUIT="" G INITQ
D BLD
INITQ Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBJTBC",$J)
D CLEAR^VALM1
Q
;
BLD ;
N IB,IBI,IBJ,IBX,IBY,IBDXI,IBLN,IBSTR,IBD,IBT,IBPRC,IBXDATA,IBZPRC,IBZDX
D F^IBCEF("N-UB-04 PROCEDURES","IBZPRC",,IBIFN)
S IBSTR=""
I +$O(IBZPRC(0))=0 S IBLN=1 F IBSTR="","Bill contains no procedures." S IBLN=$$SET(IBSTR,IBLN)
;
D F^IBCEF("N-DIAGNOSES","IBZDX",,IBIFN)
S IBX=0,IBI="" F S IBI=$O(IBZDX(IBI)) Q:'IBI S IBDXI($P(IBZDX(IBI),U,2))=IBI
S IBLN=1,IBI="" F S IBI=$O(IBZPRC(IBI)) Q:'IBI D S IBLN=$$SET(IBSTR,IBLN)
. N IBDATE ; Date of procedure
. S IBX=IBZPRC(IBI)
. S IBDATE=$P(IBX,U,2) I 'IBDATE S IBDATE=$$BDATE^IBACSV(IBIFN) ; The bills date
. S IBPRC=$$PRCD^IBCEF1($P(IBX,U),1,IBDATE) Q:IBPRC=""
. S IBT=0,IBSTR=" "_$P(IBPRC,U,2)
. ;
. I IBX["ICD0" D Q
.. S IBT=11,IBD=$P(IBPRC,U,3) S IBSTR=$$SETLN(IBD,IBSTR,IBT,60)
.. S IBT=72,IBD=$$DATE^IBJU1(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
. ;
. I +$P(IBZPRC(IBI),U,15) S IBSTR=IBSTR_" "_$$MODLST^IBEFUNC2($P(IBZPRC(IBI),U,15))
. S IBT=20,IBD=$P(IBPRC,U,3) S IBSTR=$$SETLN(IBD,IBSTR,IBT,20)
. S IBT=41,IBD=$$DATE^IBJU1(+$P(IBX,U,2)) S IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
. ;
. S IBT=51,IBY=$P(IBX,U,5) I IBY'="" S IBD="BASC: Yes" D
.. S IBSTR=$$SETLN(IBD,IBSTR,IBT,29),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,6) I IBY'="" S IBD="DIV: "_$P($G(^DG(40.8,+IBY,0)),U,1) D
.. S IBSTR=$$SETLN(IBD,IBSTR,IBT,29),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,7) I IBY'="" S IBD="CLINIC: "_$P($G(^SC(+IBY,0)),U,1) D
.. S IBSTR=$$SETLN(IBD,IBSTR,IBT,29),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,9) I IBY'="" D
.. S IBT=51,IBY=$G(^IBE(353.1,+IBY,0)),IBD="POS: "_$P(IBY,U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
.. S IBT=63,IBD=$P(IBY,U,2) S IBSTR=$$SETLN(IBD,IBSTR,IBT,12),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,10) I IBY'="" D
.. S IBT=51,IBY=$G(^IBE(353.2,+IBY,0)),IBD="TOS: "_$P(IBY,U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
.. S IBT=63,IBD=$P(IBY,U,2) S IBSTR=$$SETLN(IBD,IBSTR,IBT,17),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
. S IBT=51,IBD=$P(IBX,U,16) I IBD,$P(IBX,U,10)=7 S IBSTR=$$SETLN("MINUTES: "_$P(IBX,U,16),IBSTR,IBT,15)
. ;
. S IBT=51 F IBJ=11:1:14 S IBY=$P(IBX,U,IBJ) I IBY'="" D S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
.. S IBY=$G(IBDXI(+IBY)) Q:'IBY S IBD="DX ("_IBY_"): "
.. S IBY=+$G(IBZDX(+IBY)) Q:'IBY S IBY=$$ICD9^IBACSV(+IBY,IBDATE)
.. S IBT=51,IBD=IBD_$P(IBY,U,1) S IBSTR=$$SETLN(IBD,IBSTR,IBT,16)
.. S IBT=68,IBD=$P(IBY,U,3) S IBSTR=$$SETLN(IBD,IBSTR,IBT,12)
;
S VALMCNT=IBLN-1
Q
;
SETLN(STR,IBX,COL,WD) ;
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
Q IBX
;
SET(STR,LN) ; set up TMP array with screen data
N IBX,IBI
D SET^VALM10(LN,STR)
S LN=LN+1
SETQ Q LN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTBC 3291 printed Apr 09, 2024@21:34:40 Page 2
IBJTBC ;ALB/ARH - TPI BILL PROCEDURES SCREEN ;02-MAR-1995
+1 ;;2.0;INTEGRATED BILLING;**39,80,51,137,210,349,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBJ TP BILL PROCEDURES
+1 DO EN^VALM("IBJT BILL PROCEDURES")
+2 QUIT
+3 ;
HDR ; -- header code
+1 DO HDR^IBJTU1(+IBIFN,+DFN,12)
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBJTBC",$JOB)
NEW IBFT
+2 IF '$GET(DFN)!'$GET(IBIFN)
SET VALMQUIT=""
GOTO INITQ
+3 DO BLD
INITQ QUIT
+1 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBJTBC",$JOB)
+2 DO CLEAR^VALM1
+3 QUIT
+4 ;
BLD ;
+1 NEW IB,IBI,IBJ,IBX,IBY,IBDXI,IBLN,IBSTR,IBD,IBT,IBPRC,IBXDATA,IBZPRC,IBZDX
+2 DO F^IBCEF("N-UB-04 PROCEDURES","IBZPRC",,IBIFN)
+3 SET IBSTR=""
+4 IF +$ORDER(IBZPRC(0))=0
SET IBLN=1
FOR IBSTR="","Bill contains no procedures."
SET IBLN=$$SET(IBSTR,IBLN)
+5 ;
+6 DO F^IBCEF("N-DIAGNOSES","IBZDX",,IBIFN)
+7 SET IBX=0
SET IBI=""
FOR
SET IBI=$ORDER(IBZDX(IBI))
if 'IBI
QUIT
SET IBDXI($PIECE(IBZDX(IBI),U,2))=IBI
+8 SET IBLN=1
SET IBI=""
FOR
SET IBI=$ORDER(IBZPRC(IBI))
if 'IBI
QUIT
Begin DoDot:1
+9 ; Date of procedure
NEW IBDATE
+10 SET IBX=IBZPRC(IBI)
+11 ; The bills date
SET IBDATE=$PIECE(IBX,U,2)
IF 'IBDATE
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+12 SET IBPRC=$$PRCD^IBCEF1($PIECE(IBX,U),1,IBDATE)
if IBPRC=""
QUIT
+13 SET IBT=0
SET IBSTR=" "_$PIECE(IBPRC,U,2)
+14 ;
+15 IF IBX["ICD0"
Begin DoDot:2
+16 SET IBT=11
SET IBD=$PIECE(IBPRC,U,3)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,60)
+17 SET IBT=72
SET IBD=$$DATE^IBJU1(+$PIECE(IBX,U,2))
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
End DoDot:2
QUIT
+18 ;
+19 IF +$PIECE(IBZPRC(IBI),U,15)
SET IBSTR=IBSTR_" "_$$MODLST^IBEFUNC2($PIECE(IBZPRC(IBI),U,15))
+20 SET IBT=20
SET IBD=$PIECE(IBPRC,U,3)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,20)
+21 SET IBT=41
SET IBD=$$DATE^IBJU1(+$PIECE(IBX,U,2))
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,8)
+22 ;
+23 SET IBT=51
SET IBY=$PIECE(IBX,U,5)
IF IBY'=""
SET IBD="BASC: Yes"
Begin DoDot:2
+24 SET IBSTR=$$SETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+25 SET IBY=$PIECE(IBX,U,6)
IF IBY'=""
SET IBD="DIV: "_$PIECE($GET(^DG(40.8,+IBY,0)),U,1)
Begin DoDot:2
+26 SET IBSTR=$$SETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+27 SET IBY=$PIECE(IBX,U,7)
IF IBY'=""
SET IBD="CLINIC: "_$PIECE($GET(^SC(+IBY,0)),U,1)
Begin DoDot:2
+28 SET IBSTR=$$SETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+29 SET IBY=$PIECE(IBX,U,9)
IF IBY'=""
Begin DoDot:2
+30 SET IBT=51
SET IBY=$GET(^IBE(353.1,+IBY,0))
SET IBD="POS: "_$PIECE(IBY,U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
+31 SET IBT=63
SET IBD=$PIECE(IBY,U,2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,12)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+32 SET IBY=$PIECE(IBX,U,10)
IF IBY'=""
Begin DoDot:2
+33 SET IBT=51
SET IBY=$GET(^IBE(353.2,+IBY,0))
SET IBD="TOS: "_$PIECE(IBY,U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,11)
+34 SET IBT=63
SET IBD=$PIECE(IBY,U,2)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,17)
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+35 SET IBT=51
SET IBD=$PIECE(IBX,U,16)
IF IBD
IF $PIECE(IBX,U,10)=7
SET IBSTR=$$SETLN("MINUTES: "_$PIECE(IBX,U,16),IBSTR,IBT,15)
+36 ;
+37 SET IBT=51
FOR IBJ=11:1:14
SET IBY=$PIECE(IBX,U,IBJ)
IF IBY'=""
Begin DoDot:2
+38 SET IBY=$GET(IBDXI(+IBY))
if 'IBY
QUIT
SET IBD="DX ("_IBY_"): "
+39 SET IBY=+$GET(IBZDX(+IBY))
if 'IBY
QUIT
SET IBY=$$ICD9^IBACSV(+IBY,IBDATE)
+40 SET IBT=51
SET IBD=IBD_$PIECE(IBY,U,1)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,16)
+41 SET IBT=68
SET IBD=$PIECE(IBY,U,3)
SET IBSTR=$$SETLN(IBD,IBSTR,IBT,12)
End DoDot:2
SET IBLN=$$SET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:1
SET IBLN=$$SET(IBSTR,IBLN)
+42 ;
+43 SET VALMCNT=IBLN-1
+44 QUIT
+45 ;
SETLN(STR,IBX,COL,WD) ;
+1 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+2 QUIT IBX
+3 ;
SET(STR,LN) ; set up TMP array with screen data
+1 NEW IBX,IBI
+2 DO SET^VALM10(LN,STR)
+3 SET LN=LN+1
SETQ QUIT LN
