- 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 Jan 18, 2025@03:25:01 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