- IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995
- ;;2.0;INTEGRATED BILLING;**39,80,155,320,516**;21-MAR-94;Build 123
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- CONT ; Continuation of Claim Information Screen Build
- ; reason cancelled
- I $P(IBD0,U,13)=7 D
- . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0
- . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
- . ;
- . S IBGRPB=IBLN,IBLR=1
- . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
- . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
- . S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
- ;
- S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
- S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
- S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- ;
- S IBGRPB=IBLN,IBLR=1
- ;
- I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- ;
- ; Patch 320 - added bill cloning history to TPJI report.
- N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
- S IBINDENT=0
- D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history
- ;
- ; attempt to go one claim forward from the current claim
- S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
- S IBNEXT=$Q(@IBCURR)
- I IBNEXT'="" D
- . N IBX S IBX=@IBNEXT
- . S IBT="Copied: "
- . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
- . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- . S IBINDENT=1
- . Q
- ;
- ; now go backwards for claim cloning history all the way back
- S IBBCH=IBCURR
- F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D
- . N IBX S IBX=@IBBCH
- . S IBT="Copied: " I IBINDENT S IBT=" "_IBT
- . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
- . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- . S IBT="Copied From: " I IBINDENT S IBT=" "_IBT
- . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- . S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT
- . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- . S IBINDENT=1
- . Q
- ;
- I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X D
- . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- ;
- N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
- . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26,IBTW(0)=0
- . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
- . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
- . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
- . S IBTC(1)=0,IBTW(1)=0,IBSW(1)=68,IBLR=1,IBNC(1)=0
- . S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance"
- . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
- . S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D
- .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
- .. S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ S IBK="" F S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK="" D
- ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK)
- ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
- ... I +IBK D
- .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
- .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status
- .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
- .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
- ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
- .... S IBD=$$SLINE(IBD,IBX,30,3)
- .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
- .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
- .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
- ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
- ;
- ;IB*2.0*516 - Display links from 3rd party bill to 1st party bill(s)
- K ^TMP("IBRBF",$J)
- D RELBILL^IBRFN(IBIFN)
- N IBCIFN,IBCNT
- S IBCNT=0,IBCIFN="" F S IBCIFN=$O(^TMP("IBRBF",$J,IBIFN,IBCIFN)) Q:IBCIFN="" D
- . I $P(^(IBCIFN),"^",6)["RX COPAY" K ^TMP("IBRBF",$J,IBIFN,IBCIFN) Q
- . S IBCNT=IBCNT+1
- D HDR2
- I IBCNT=0 S (IBT,IBD)="",IBX="No Links to 1st Party Bills Found",IBD=$$SLINE(IBD,IBX,0,35),IBLN=$$SET(IBT,IBD,IBLN,IBLR) Q
- S (IBD,IBX,IBT)=""
- S IBCIFN="" F S IBCIFN=$O(^TMP("IBRBF",$J,IBIFN,IBCIFN)) Q:IBCIFN="" D PRINT2
- K ^TMP("IBRBF",$J)
- Q
- ;
- EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
- N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
- S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
- S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1)
- S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER)
- Q Y
- ;
- SET(IBT,IBD,IBLN,IBLR) ;
- N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
- Q LN
- ;
- SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
- S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
- Q IBD
- ;
- HDR2 ;Print the header for first party bills - IB*2*516
- S (IBT,IBD)="",IBLR=1,IBNC(1)=26
- S IBLN=$$SET(IBT,IBD,IBLN,1)
- S IBT="Related First Party Charges" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
- S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
- S IBTC(1)=0,IBTW(1)=1,IBSW(1)=80,IBLR=1,IBNC(1)=26
- S IBT="Bill# Charge Type Status Amt Billed On Hold Balance"
- S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
- Q
- ;
- PRINT2 ;Print the detail line for a first party bill - IB*2*516
- S IBTC(1)=0,IBTW(1)=0,IBSW(1)=80,IBLR=1
- S IBDAT=$G(^TMP("IBRBF",$J,IBIFN,IBCIFN)),IBD=""
- S IBX=$P(IBDAT,"^",4) S:IBX="" IBX="Not Assigned" S IBD=$$SLINE(IBD,IBX,0,13)
- S IBX=$P(IBDAT,"^",6),IBD=$$SLINE(IBD,IBX,14,12)
- S IBX=$$GET1^DIQ(350,IBCIFN_",",.05) S:IBX="" IBX="Incomplete" S IBD=$$SLINE(IBD,IBX,27,11)
- S IBFN=$P(IBDAT,"^",4) I IBFN S IBFN=$O(^PRCA(430,"B",IBFN,0))
- S IBX=$J($P(IBDAT,"^",5),9,2),IBD=$$SLINE(IBD,IBX,40,10)
- S IBX=$P(IBDAT,"^",7),IBD=$$SLINE(IBD,IBX,53,10)
- S IBX=$J($S($G(^PRCA(430,+IBFN,7)):+($P(^(7),"^")+$P(^(7),"^",2)+$P(^(7),"^",3)+$P(^(7),"^",4)+$P(^(7),"^",4)),1:0),9,2),IBD=$$SLINE(IBD,IBX,63,10)
- S IBLN=$$SET(IBT,IBD,IBLN,1)
- Q
- ;
- STAT(RCIBFN) ;AR Status
- I '$G(RCIBFN) Q ""
- N RCSTAT
- S RCSTAT=$P($G(^PRCA(430,+RCIBFN,0)),"^",8),RCSTAT=$P($G(^PRCA(430.3,+RCSTAT,0)),"^",2)
- Q RCSTAT
- ;
- DATE(X) ; Convert FileMan date to mm/dd/yy
- Q $S($G(X):$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTCA2 7057 printed Feb 18, 2025@23:50:15 Page 2
- IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995
- +1 ;;2.0;INTEGRATED BILLING;**39,80,155,320,516**;21-MAR-94;Build 123
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- CONT ; Continuation of Claim Information Screen Build
- +1 ; reason cancelled
- +2 IF $PIECE(IBD0,U,13)=7
- Begin DoDot:1
- +3 SET (IBNC(1),IBTC(1))=2
- SET (IBNC(2),IBTC(2))=0
- SET IBNC(3)=28
- SET IBTW(1)=29
- SET IBTW(2)=0
- SET IBSW(1)=49
- SET IBSW(2)=0
- +4 SET (IBT,IBD)=""
- SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +5 ;
- +6 SET IBGRPB=IBLN
- SET IBLR=1
- +7 KILL IBY
- DO RCANC^IBJTU2(IBIFN,.IBY,50)
- +8 SET IBT="Reason Cancelled by ("_$PIECE(IBY,U,3)_"): "
- +9 SET IBI=0
- FOR
- SET IBI=$ORDER(IBY(IBI))
- if 'IBI
- QUIT
- SET IBD=IBY(IBI)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- SET IBT=""
- End DoDot:1
- +10 ;
- +11 SET (IBLN,VALMCNT)=$SELECT(IBLN>IBGRPE:IBLN,1:IBGRPE)
- +12 SET (IBNC(1),IBTC(1))=2
- SET IBTW(1)=16
- SET IBSW(1)=50
- +13 SET (IBT,IBD)=""
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +14 ;
- +15 SET IBGRPB=IBLN
- SET IBLR=1
- +16 ;
- +17 IF +$PIECE(IBDS,U,1)
- SET IBT="Entered: "
- SET IBD=$$EXT(IBDS,1,2)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +18 IF +$PIECE(IBDS,U,4)
- SET IBT="Initial Review: "
- SET IBD=$$EXT(IBDS,4,5)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +19 IF +$PIECE(IBDS,U,7)
- SET IBT="MRA Request: "
- SET IBD=$$EXT(IBDS,7,8)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +20 IF +$PIECE(IBDS,U,10)
- SET IBT="Authorized: "
- SET IBD=$$EXT(IBDS,10,11)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +21 IF +$PIECE(IBDS,U,12)
- SET IBT="First Printed: "
- SET IBD=$$EXT(IBDS,12,13)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +22 IF $PIECE(IBDS,U,14)>$PIECE(IBDS,U,12)
- SET IBT="Last Printed: "
- SET IBD=$$EXT(IBDS,14,15)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +23 IF +$PIECE(IBDS,U,17)
- SET IBT="Cancelled: "
- SET IBD=$$EXT(IBDS,17,18)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +24 ;
- +25 ; Patch 320 - added bill cloning history to TPJI report.
- +26 NEW IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
- +27 SET IBINDENT=0
- +28 ; utility to pull cloning history
- DO EN^IBCCR(IBIFN,.IBCCR)
- +29 ;
- +30 ; attempt to go one claim forward from the current claim
- +31 SET IBCURR="IBCCR("_+$PIECE(IBDS,U,1)_","_IBIFN_")"
- +32 SET IBNEXT=$QUERY(@IBCURR)
- +33 IF IBNEXT'=""
- Begin DoDot:1
- +34 NEW IBX
- SET IBX=@IBNEXT
- +35 SET IBT="Copied: "
- +36 SET IBD=$$FMTE^XLFDT($PIECE(IBX,U,1),"2Z")_" by "_$PIECE(IBX,U,3)
- +37 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +38 SET IBT="Copied To: "
- SET IBD=$PIECE(IBX,U,2)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +39 SET IBINDENT=1
- +40 QUIT
- End DoDot:1
- +41 ;
- +42 ; now go backwards for claim cloning history all the way back
- +43 SET IBBCH=IBCURR
- +44 FOR
- SET IBBCH=$QUERY(@IBBCH,-1)
- if IBBCH=""
- QUIT
- Begin DoDot:1
- +45 NEW IBX
- SET IBX=@IBBCH
- +46 SET IBT="Copied: "
- IF IBINDENT
- SET IBT=" "_IBT
- +47 SET IBD=$$FMTE^XLFDT($PIECE(IBX,U,1),"2Z")_" by "_$PIECE(IBX,U,3)
- +48 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +49 SET IBT="Copied From: "
- IF IBINDENT
- SET IBT=" "_IBT
- +50 SET IBD=$PIECE(IBX,U,2)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +51 SET IBT="Reason Copied: "
- IF IBINDENT
- SET IBT=" "_IBT
- +52 SET IBD=$PIECE(IBX,U,4)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- +53 SET IBINDENT=1
- +54 QUIT
- End DoDot:1
- +55 ;
- +56 IF $DATA(^DGCR(399,IBIFN,"R","AC",1))
- SET IBT="Returned to AR: "
- SET X=0
- FOR
- SET X=$ORDER(^DGCR(399,IBIFN,"R","AC",1,X))
- if 'X
- QUIT
- Begin DoDot:1
- +57 SET IBY=$GET(^DGCR(399,IBIFN,"R",X,0))
- SET IBD=$$EXT(IBY,1,2)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- End DoDot:1
- +58 ;
- +59 NEW IBCOB,IBX,IBY,IBI,IBJ,IBK
- DO BCOB^IBCU3(IBIFN,.IBCOB)
- IF $ORDER(IBCOB(0))
- Begin DoDot:1
- +60 SET IBTC(1)=2
- SET IBTW(1)=12
- SET IBSW(1)=68
- SET IBLR=1
- SET IBNC(1)=26
- SET IBTW(0)=0
- +61 SET (IBT,IBD)=""
- SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +62 SET IBT="Payers and Related Bills"
- SET IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
- +63 SET (IBT,IBD)=""
- SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +64 SET IBTC(1)=0
- SET IBTW(1)=0
- SET IBSW(1)=68
- SET IBLR=1
- SET IBNC(1)=0
- +65 SET IBT=""
- SET IBD="Insurance Co. Bill # Status Original Collected Balance"
- +66 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- DO CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
- +67 SET IBI=0
- FOR
- SET IBI=$ORDER(IBCOB(IBI))
- if 'IBI
- QUIT
- Begin DoDot:2
- +68 SET IBT=$SELECT(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
- +69 SET IBJ=0
- FOR
- SET IBJ=$ORDER(IBCOB(IBI,IBJ))
- if 'IBJ
- QUIT
- SET IBK=""
- FOR
- SET IBK=$ORDER(IBCOB(IBI,IBJ,IBK))
- if IBK=""
- QUIT
- Begin DoDot:3
- +70 SET IBD=""
- SET IBY=$$BILL^RCJIBFN2(IBK)
- +71 SET IBX=$PIECE($GET(^DIC(36,+IBJ,0)),U,1)
- SET IBD=$$SLINE(IBD,IBX,0,15)
- +72 IF +IBK
- Begin DoDot:4
- +73 SET IBX=$PIECE($GET(^DGCR(399,+IBK,0)),U,1)
- SET IBD=$$SLINE(IBD,IBX,17,10)
- +74 ;bill status
- SET IBX=$PIECE($$STNO^RCJIBFN2(+$PIECE(IBY,U,2)),U,2)
- +75 ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
- +76 IF $$EDIACTV^IBCEF4(2)
- IF $$COBN^IBCEF(+IBK)>1
- IF IBI=1
- IF $$MCRWNR^IBEFUNC(+IBJ)
- Begin DoDot:5
- +77 ;blank out status & reset WNR amounts
- SET IBX=" "
- SET IBY="0^^0^0^0"
- End DoDot:5
- +78 SET IBD=$$SLINE(IBD,IBX,30,3)
- +79 SET IBX=$JUSTIFY($PIECE(IBY,U,1),10,2)
- SET IBD=$$SLINE(IBD,IBX,35,10)
- +80 SET IBX=$JUSTIFY($PIECE(IBY,U,4),10,2)
- SET IBD=$$SLINE(IBD,IBX,46,10)
- +81 SET IBX=$JUSTIFY($PIECE(IBY,U,3),10,2)
- SET IBD=$$SLINE(IBD,IBX,57,10)
- End DoDot:4
- +82 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- SET IBT=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +83 ;
- +84 ;IB*2.0*516 - Display links from 3rd party bill to 1st party bill(s)
- +85 KILL ^TMP("IBRBF",$JOB)
- +86 DO RELBILL^IBRFN(IBIFN)
- +87 NEW IBCIFN,IBCNT
- +88 SET IBCNT=0
- SET IBCIFN=""
- FOR
- SET IBCIFN=$ORDER(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
- if IBCIFN=""
- QUIT
- Begin DoDot:1
- +89 IF $PIECE(^(IBCIFN),"^",6)["RX COPAY"
- KILL ^TMP("IBRBF",$JOB,IBIFN,IBCIFN)
- QUIT
- +90 SET IBCNT=IBCNT+1
- End DoDot:1
- +91 DO HDR2
- +92 IF IBCNT=0
- SET (IBT,IBD)=""
- SET IBX="No Links to 1st Party Bills Found"
- SET IBD=$$SLINE(IBD,IBX,0,35)
- SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- QUIT
- +93 SET (IBD,IBX,IBT)=""
- +94 SET IBCIFN=""
- FOR
- SET IBCIFN=$ORDER(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
- if IBCIFN=""
- QUIT
- DO PRINT2
- +95 KILL ^TMP("IBRBF",$JOB)
- +96 QUIT
- +97 ;
- EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
- +1 NEW X,Y
- SET Y=""
- SET STR=$GET(STR)
- SET DT=+$GET(DT)
- SET USER=+$GET(USER)
- +2 SET X=$PIECE(STR,U,DT)
- SET DT=""
- IF +X
- SET DT=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
- +3 SET X=$PIECE(STR,U,USER)
- SET USER=""
- IF +X
- SET USER=$PIECE($GET(^VA(200,+X,0)),U,1)
- +4 SET Y=DT_" by "_$SELECT(USER="":"UNKNOWN",1:USER)
- +5 QUIT Y
- +6 ;
- SET(IBT,IBD,IBLN,IBLR) ;
- +1 NEW LN
- SET LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
- +2 QUIT LN
- +3 ;
- SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
- +1 SET IBD=$EXTRACT(IBD,1,(COL-1))
- SET IBD=IBD_$JUSTIFY("",(COL-$LENGTH(IBD)))
- SET IBD=IBD_$EXTRACT(DATA,1,WD)
- +2 QUIT IBD
- +3 ;
- HDR2 ;Print the header for first party bills - IB*2*516
- +1 SET (IBT,IBD)=""
- SET IBLR=1
- SET IBNC(1)=26
- +2 SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +3 SET IBT="Related First Party Charges"
- SET IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
- +4 SET (IBT,IBD)=""
- SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +5 SET IBTC(1)=0
- SET IBTW(1)=1
- SET IBSW(1)=80
- SET IBLR=1
- SET IBNC(1)=26
- +6 SET IBT="Bill# Charge Type Status Amt Billed On Hold Balance"
- +7 SET IBLN=$$SET(IBT,IBD,IBLN,IBLR)
- DO CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
- +8 QUIT
- +9 ;
- PRINT2 ;Print the detail line for a first party bill - IB*2*516
- +1 SET IBTC(1)=0
- SET IBTW(1)=0
- SET IBSW(1)=80
- SET IBLR=1
- +2 SET IBDAT=$GET(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
- SET IBD=""
- +3 SET IBX=$PIECE(IBDAT,"^",4)
- if IBX=""
- SET IBX="Not Assigned"
- SET IBD=$$SLINE(IBD,IBX,0,13)
- +4 SET IBX=$PIECE(IBDAT,"^",6)
- SET IBD=$$SLINE(IBD,IBX,14,12)
- +5 SET IBX=$$GET1^DIQ(350,IBCIFN_",",.05)
- if IBX=""
- SET IBX="Incomplete"
- SET IBD=$$SLINE(IBD,IBX,27,11)
- +6 SET IBFN=$PIECE(IBDAT,"^",4)
- IF IBFN
- SET IBFN=$ORDER(^PRCA(430,"B",IBFN,0))
- +7 SET IBX=$JUSTIFY($PIECE(IBDAT,"^",5),9,2)
- SET IBD=$$SLINE(IBD,IBX,40,10)
- +8 SET IBX=$PIECE(IBDAT,"^",7)
- SET IBD=$$SLINE(IBD,IBX,53,10)
- +9 SET IBX=$JUSTIFY($SELECT($GET(^PRCA(430,+IBFN,7)):+($PIECE(^(7),"^")+$PIECE(^(7),"^",2)+$PIECE(^(7),"^",3)+$PIECE(^(7),"^",4)+$PIECE(^(7),"^",4)),1:0),9,2)
- SET IBD=$$SLINE(IBD,IBX,63,10)
- +10 SET IBLN=$$SET(IBT,IBD,IBLN,1)
- +11 QUIT
- +12 ;
- STAT(RCIBFN) ;AR Status
- +1 IF '$GET(RCIBFN)
- QUIT ""
- +2 NEW RCSTAT
- +3 SET RCSTAT=$PIECE($GET(^PRCA(430,+RCIBFN,0)),"^",8)
- SET RCSTAT=$PIECE($GET(^PRCA(430.3,+RCSTAT,0)),"^",2)
- +4 QUIT RCSTAT
- +5 ;
- DATE(X) ; Convert FileMan date to mm/dd/yy
- +1 QUIT $SELECT($GET(X):$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")
- +2 ;