IBACCWLEE4 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display Formats ; 12-SEP-2023 ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $G(^PRCA(430,+IBFN,7)) in ICR #389
; Reference to $O(^PRCA(430,"B",IBFN,0)) in ICR #389
; Reference to $P($G(^PRCA(430,+RCIBFN,0)),"^",8) in ICR #389
; Reference to $P($G(^PRCA(430.3,+RCSTAT,0)),"^",2) in ICR #3337
Q
;
;CLONED FROM RTN IBJTBB - TPI BILL DIAGNOSIS SCREEN
;CALLED FROM IBACCWLEE
DIAGBLD(IBIFN,IBLN,VALMCNT) ;
N IBADX,IBI,IBX,IBCNT,IBSTR,IBDATE
S IBDATE=$$BDATE^IBACSV(IBIFN)
;D SET^IBCSC4D(IBIFN,"",.IBADX) I $D(IBADX)'>1 S IBLN=1 F IBSTR="","Bill contains no diagnosis." S IBLN=$$SET(IBSTR,IBLN,1,80)
D SET^IBCSC4D(IBIFN,"",.IBADX)
I $D(IBADX)'>1 S IBLN=IBLN+1 F IBSTR="","Bill contains no diagnosis." S IBLN=$$DIAGSET(IBSTR,IBLN,1,80)
S IBI=""
S IBLN=IBLN+1
S IBCNT=0
F S IBI=$O(IBADX(IBI)) Q:'IBI D S IBLN=$$DIAGSET(IBSTR,IBLN,1,80)
. S IBCNT=IBCNT+1,IBX=$$ICD9^IBACSV(+IBADX(IBI),IBDATE)
. S IBSTR=$J("",1)_$J(IBCNT,3)_") "_$P(IBX,U,1)_$J("",(10-$L($P(IBX,U,1))))_$P(IBX,U,3)
;
S VALMCNT=IBLN-1
Q
;
DIAGSET(STR,LN,COL,WD,RV) ; set up TMP array with screen data
D SET^VALM10(LN,STR)
S LN=LN+1
Q LN
;
;CLONED FROM RTN IBJTBC TPI BILL PROCEDURES SCREEN
;CALLED FROM IBACCWLEE
PROCBLD(IBIFN,IBLN,VALMCNT) ;
N IB,IBI,IBJ,IBX,IBY,IBDXI,IBSTR,IBD,IBT,IBPRC,IBXDATA,IBZPRC,IBZDX
D F^IBCEF("N-UB-04 PROCEDURES","IBZPRC",,IBIFN)
S IBSTR=""
;I +$O(IBZPRC(0))=0 F IBSTR="","Bill contains no procedures." S IBLN=$$PROCSET(IBSTR,IBLN)
I +$O(IBZPRC(0))=0 F IBSTR="","Bill contains no procedures.","" S IBLN=$$PROCSET(IBSTR,IBLN) ;TPF;IB*2*770v48;EBILL-6073 ADD A BLANK LINE FOR READABILITY
;
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=IBLN+1 ;TPF;IB*2*770v48;EBILL-6073
S IBI=""
F S IBI=$O(IBZPRC(IBI)) Q:'IBI D S IBLN=$$PROCSET(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=$$PROCSETLN(IBD,IBSTR,IBT,60)
.. S IBT=72,IBD=$$DATE^IBJU1(+$P(IBX,U,2)) S IBSTR=$$PROCSETLN(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=$$PROCSETLN(IBD,IBSTR,IBT,20)
. S IBT=41,IBD=$$DATE^IBJU1(+$P(IBX,U,2)) S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,8)
. ;
. S IBT=51,IBY=$P(IBX,U,5) I IBY'="" S IBD="BASC: Yes" D
.. S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29),IBLN=$$PROCSET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,6) I IBY'="" S IBD="DIV: "_$P($G(^DG(40.8,+IBY,0)),U,1) D ;ICR #417
.. S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29),IBLN=$$PROCSET(IBSTR,IBLN),IBSTR=""
. S IBY=$P(IBX,U,7) I IBY'="" S IBD="CLINIC: "_$P($G(^SC(+IBY,0)),U,1) D ;ICR #401
.. S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29),IBLN=$$PROCSET(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=$$PROCSETLN(IBD,IBSTR,IBT,11)
.. S IBT=63,IBD=$P(IBY,U,2) S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,12),IBLN=$$PROCSET(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=$$PROCSETLN(IBD,IBSTR,IBT,11)
.. S IBT=63,IBD=$P(IBY,U,2) S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,17),IBLN=$$PROCSET(IBSTR,IBLN),IBSTR=""
. S IBT=51,IBD=$P(IBX,U,16) I IBD,$P(IBX,U,10)=7 S IBSTR=$$PROCSETLN("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=$$PROCSET(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=$$PROCSETLN(IBD,IBSTR,IBT,16)
.. S IBT=68,IBD=$P(IBY,U,3) S IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,12)
;
S VALMCNT=IBLN-1
Q
;
PROCSETLN(STR,IBX,COL,WD) ;
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
Q IBX
;
PROCSET(STR,LN) ; set up TMP array with screen data
N IBX,IBI
D SET^VALM10(LN,STR)
S LN=LN+1
PROCSETQ Q LN
Q
;
;A
PRINT2 ;Print the detail line for a first party bill - IB*2*516
N IBDAT,IBFN ;TPF XINDEX
N IBTC,IBTW,IBSW ;MJL XINDEX
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)) ;ICR #389
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),"^",5)),1:0),9,2),IBD=$$SLINE(IBD,IBX,63,10) ;ICR #389
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) ;ICR #389 ;ICR #3337
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:"")
;
EMPL(DFN) ; returns employer name
Q $P($G(^DPT(+DFN,.311)),U,1) ;;ICR #426
;
;SET(TTL,DATA,LN,LR) ;
N IBY
S IBY=$J(TTL,IBTW(LR))_DATA D SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
S LN=LN+1
Q LN
;
;SETN(TTL,LN,LR,RV) ;
N IBY
S IBY=" "_TTL_" " D SET1(IBY,LN,IBNC(LR),$L(IBY),$G(RV))
S LN=LN+1
S VALMCNT=LN ;TPF
Q LN
;
;SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
N IBX S IBX=$G(@VALMAR@(LN,0))
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
D SET^VALM10(LN,IBX) I $G(RV)'="" D CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
Q
SET(IBT,IBD,IBLN,IBLR) ;
N LN S LN=$$SET2(IBT,IBD,IBLN,IBLR) ;TPF
S VALMCNT=IBLN
Q LN
;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
N IBX S IBX=$G(@VALMAR@(LN,0))
S IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
D SET^VALM10(LN,IBX) I $G(RV)'="" D CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
Q
;
SET2(TTL,DATA,LN,LR) ;EP -
N IBY
S IBY=$J(TTL,IBTW(LR))_DATA D SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
S LN=LN+1
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
;
SETN(TTL,LN,LR,RV) ;EP -
N IBY
S IBY=" "_TTL_" " D SET1(IBY,LN,IBNC(LR),$L(IBY),$G(RV))
S LN=LN+1
Q LN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLEE4 6846 printed May 25, 2026@12:10 Page 2
IBACCWLEE4 ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Expand Encounter Display Formats ; 12-SEP-2023 ; 12-SEP-2023
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to $G(^PRCA(430,+IBFN,7)) in ICR #389
+5 ; Reference to $O(^PRCA(430,"B",IBFN,0)) in ICR #389
+6 ; Reference to $P($G(^PRCA(430,+RCIBFN,0)),"^",8) in ICR #389
+7 ; Reference to $P($G(^PRCA(430.3,+RCSTAT,0)),"^",2) in ICR #3337
+8 QUIT
+9 ;
+10 ;CLONED FROM RTN IBJTBB - TPI BILL DIAGNOSIS SCREEN
+11 ;CALLED FROM IBACCWLEE
DIAGBLD(IBIFN,IBLN,VALMCNT) ;
+1 NEW IBADX,IBI,IBX,IBCNT,IBSTR,IBDATE
+2 SET IBDATE=$$BDATE^IBACSV(IBIFN)
+3 ;D SET^IBCSC4D(IBIFN,"",.IBADX) I $D(IBADX)'>1 S IBLN=1 F IBSTR="","Bill contains no diagnosis." S IBLN=$$SET(IBSTR,IBLN,1,80)
+4 DO SET^IBCSC4D(IBIFN,"",.IBADX)
+5 IF $DATA(IBADX)'>1
SET IBLN=IBLN+1
FOR IBSTR="","Bill contains no diagnosis."
SET IBLN=$$DIAGSET(IBSTR,IBLN,1,80)
+6 SET IBI=""
+7 SET IBLN=IBLN+1
+8 SET IBCNT=0
+9 FOR
SET IBI=$ORDER(IBADX(IBI))
if 'IBI
QUIT
Begin DoDot:1
+10 SET IBCNT=IBCNT+1
SET IBX=$$ICD9^IBACSV(+IBADX(IBI),IBDATE)
+11 SET IBSTR=$JUSTIFY("",1)_$JUSTIFY(IBCNT,3)_") "_$PIECE(IBX,U,1)_$JUSTIFY("",(10-$LENGTH($PIECE(IBX,U,1))))_$PIECE(IBX,U,3)
End DoDot:1
SET IBLN=$$DIAGSET(IBSTR,IBLN,1,80)
+12 ;
+13 SET VALMCNT=IBLN-1
+14 QUIT
+15 ;
DIAGSET(STR,LN,COL,WD,RV) ; set up TMP array with screen data
+1 DO SET^VALM10(LN,STR)
+2 SET LN=LN+1
+3 QUIT LN
+4 ;
+5 ;CLONED FROM RTN IBJTBC TPI BILL PROCEDURES SCREEN
+6 ;CALLED FROM IBACCWLEE
PROCBLD(IBIFN,IBLN,VALMCNT) ;
+1 NEW IB,IBI,IBJ,IBX,IBY,IBDXI,IBSTR,IBD,IBT,IBPRC,IBXDATA,IBZPRC,IBZDX
+2 DO F^IBCEF("N-UB-04 PROCEDURES","IBZPRC",,IBIFN)
+3 SET IBSTR=""
+4 ;I +$O(IBZPRC(0))=0 F IBSTR="","Bill contains no procedures." S IBLN=$$PROCSET(IBSTR,IBLN)
+5 ;TPF;IB*2*770v48;EBILL-6073 ADD A BLANK LINE FOR READABILITY
IF +$ORDER(IBZPRC(0))=0
FOR IBSTR="","Bill contains no procedures.",""
SET IBLN=$$PROCSET(IBSTR,IBLN)
+6 ;
+7 DO F^IBCEF("N-DIAGNOSES","IBZDX",,IBIFN)
+8 SET IBX=0
SET IBI=""
FOR
SET IBI=$ORDER(IBZDX(IBI))
if 'IBI
QUIT
SET IBDXI($PIECE(IBZDX(IBI),U,2))=IBI
+9 ;S IBLN=IBLN+1 ;TPF;IB*2*770v48;EBILL-6073
+10 SET IBI=""
+11 FOR
SET IBI=$ORDER(IBZPRC(IBI))
if 'IBI
QUIT
Begin DoDot:1
+12 ; Date of procedure
NEW IBDATE
+13 SET IBX=IBZPRC(IBI)
+14 ; The bills date
SET IBDATE=$PIECE(IBX,U,2)
IF 'IBDATE
SET IBDATE=$$BDATE^IBACSV(IBIFN)
+15 SET IBPRC=$$PRCD^IBCEF1($PIECE(IBX,U),1,IBDATE)
if IBPRC=""
QUIT
+16 SET IBT=0
SET IBSTR=" "_$PIECE(IBPRC,U,2)
+17 ;
+18 IF IBX["ICD0"
Begin DoDot:2
+19 SET IBT=11
SET IBD=$PIECE(IBPRC,U,3)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,60)
+20 SET IBT=72
SET IBD=$$DATE^IBJU1(+$PIECE(IBX,U,2))
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,8)
End DoDot:2
QUIT
+21 ;
+22 IF +$PIECE(IBZPRC(IBI),U,15)
SET IBSTR=IBSTR_" "_$$MODLST^IBEFUNC2($PIECE(IBZPRC(IBI),U,15))
+23 SET IBT=20
SET IBD=$PIECE(IBPRC,U,3)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,20)
+24 SET IBT=41
SET IBD=$$DATE^IBJU1(+$PIECE(IBX,U,2))
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,8)
+25 ;
+26 SET IBT=51
SET IBY=$PIECE(IBX,U,5)
IF IBY'=""
SET IBD="BASC: Yes"
Begin DoDot:2
+27 SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+28 ;ICR #417
SET IBY=$PIECE(IBX,U,6)
IF IBY'=""
SET IBD="DIV: "_$PIECE($GET(^DG(40.8,+IBY,0)),U,1)
Begin DoDot:2
+29 SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+30 ;ICR #401
SET IBY=$PIECE(IBX,U,7)
IF IBY'=""
SET IBD="CLINIC: "_$PIECE($GET(^SC(+IBY,0)),U,1)
Begin DoDot:2
+31 SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,29)
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+32 SET IBY=$PIECE(IBX,U,9)
IF IBY'=""
Begin DoDot:2
+33 SET IBT=51
SET IBY=$GET(^IBE(353.1,+IBY,0))
SET IBD="POS: "_$PIECE(IBY,U,1)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,11)
+34 SET IBT=63
SET IBD=$PIECE(IBY,U,2)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,12)
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+35 SET IBY=$PIECE(IBX,U,10)
IF IBY'=""
Begin DoDot:2
+36 SET IBT=51
SET IBY=$GET(^IBE(353.2,+IBY,0))
SET IBD="TOS: "_$PIECE(IBY,U,1)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,11)
+37 SET IBT=63
SET IBD=$PIECE(IBY,U,2)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,17)
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:2
+38 SET IBT=51
SET IBD=$PIECE(IBX,U,16)
IF IBD
IF $PIECE(IBX,U,10)=7
SET IBSTR=$$PROCSETLN("MINUTES: "_$PIECE(IBX,U,16),IBSTR,IBT,15)
+39 ;
+40 SET IBT=51
FOR IBJ=11:1:14
SET IBY=$PIECE(IBX,U,IBJ)
IF IBY'=""
Begin DoDot:2
+41 SET IBY=$GET(IBDXI(+IBY))
if 'IBY
QUIT
SET IBD="DX ("_IBY_"): "
+42 SET IBY=+$GET(IBZDX(+IBY))
if 'IBY
QUIT
SET IBY=$$ICD9^IBACSV(+IBY,IBDATE)
+43 SET IBT=51
SET IBD=IBD_$PIECE(IBY,U,1)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,16)
+44 SET IBT=68
SET IBD=$PIECE(IBY,U,3)
SET IBSTR=$$PROCSETLN(IBD,IBSTR,IBT,12)
End DoDot:2
SET IBLN=$$PROCSET(IBSTR,IBLN)
SET IBSTR=""
End DoDot:1
SET IBLN=$$PROCSET(IBSTR,IBLN)
+45 ;
+46 SET VALMCNT=IBLN-1
+47 QUIT
+48 ;
PROCSETLN(STR,IBX,COL,WD) ;
+1 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+2 QUIT IBX
+3 ;
PROCSET(STR,LN) ; set up TMP array with screen data
+1 NEW IBX,IBI
+2 DO SET^VALM10(LN,STR)
+3 SET LN=LN+1
PROCSETQ QUIT LN
+1 QUIT
+2 ;
+3 ;A
PRINT2 ;Print the detail line for a first party bill - IB*2*516
+1 ;TPF XINDEX
NEW IBDAT,IBFN
+2 ;MJL XINDEX
NEW IBTC,IBTW,IBSW
+3 SET IBTC(1)=0
SET IBTW(1)=0
SET IBSW(1)=80
SET IBLR=1
+4 SET IBDAT=$GET(^TMP("IBRBF",$JOB,IBIFN,IBCIFN))
SET IBD=""
+5 SET IBX=$PIECE(IBDAT,"^",4)
if IBX=""
SET IBX="Not Assigned"
SET IBD=$$SLINE(IBD,IBX,0,13)
+6 SET IBX=$PIECE(IBDAT,"^",6)
SET IBD=$$SLINE(IBD,IBX,14,12)
+7 SET IBX=$$GET1^DIQ(350,IBCIFN_",",.05)
if IBX=""
SET IBX="Incomplete"
SET IBD=$$SLINE(IBD,IBX,27,11)
+8 ;ICR #389
SET IBFN=$PIECE(IBDAT,"^",4)
IF IBFN
SET IBFN=$ORDER(^PRCA(430,"B",IBFN,0))
+9 SET IBX=$JUSTIFY($PIECE(IBDAT,"^",5),9,2)
SET IBD=$$SLINE(IBD,IBX,40,10)
+10 SET IBX=$PIECE(IBDAT,"^",7)
SET IBD=$$SLINE(IBD,IBX,53,10)
+11 ;ICR #389
SET IBX=$JUSTIFY($SELECT($GET(^PRCA(430,+IBFN,7)):+($PIECE(^(7),"^")+$PIECE(^(7),"^",2)+$PIECE(^(7),"^",3)+$PIECE(^(7),"^",4)+$PIECE(^(7),"^",5)),1:0),9,2)
SET IBD=$$SLINE(IBD,IBX,63,10)
+12 SET IBLN=$$SET(IBT,IBD,IBLN,1)
+13 QUIT
+14 ;
STAT(RCIBFN) ;AR Status
+1 IF '$GET(RCIBFN)
QUIT ""
+2 NEW RCSTAT
+3 ;ICR #389 ;ICR #3337
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 ;
EMPL(DFN) ; returns employer name
+1 ;;ICR #426
QUIT $PIECE($GET(^DPT(+DFN,.311)),U,1)
+2 ;
+3 ;SET(TTL,DATA,LN,LR) ;
+4 NEW IBY
+5 SET IBY=$JUSTIFY(TTL,IBTW(LR))_DATA
DO SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
+6 SET LN=LN+1
+7 QUIT LN
+8 ;
+9 ;SETN(TTL,LN,LR,RV) ;
+10 NEW IBY
+11 SET IBY=" "_TTL_" "
DO SET1(IBY,LN,IBNC(LR),$LENGTH(IBY),$GET(RV))
+12 SET LN=LN+1
+13 ;TPF
SET VALMCNT=LN
+14 QUIT LN
+15 ;
+16 ;SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
+17 NEW IBX
SET IBX=$GET(@VALMAR@(LN,0))
+18 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+19 DO SET^VALM10(LN,IBX)
IF $GET(RV)'=""
DO CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
+20 QUIT
SET(IBT,IBD,IBLN,IBLR) ;
+1 ;TPF
NEW LN
SET LN=$$SET2(IBT,IBD,IBLN,IBLR)
+2 SET VALMCNT=IBLN
+3 QUIT LN
+4 ;
SET1(STR,LN,COL,WD,RV) ; set up TMP array with screen data
+1 NEW IBX
SET IBX=$GET(@VALMAR@(LN,0))
+2 SET IBX=$$SETSTR^VALM1(STR,IBX,COL,WD)
+3 DO SET^VALM10(LN,IBX)
IF $GET(RV)'=""
DO CNTRL^VALM10(LN,COL,WD,IORVON,IORVOFF)
+4 QUIT
+5 ;
SET2(TTL,DATA,LN,LR) ;EP -
+1 NEW IBY
+2 SET IBY=$JUSTIFY(TTL,IBTW(LR))_DATA
DO SET1(IBY,LN,IBTC(LR),(IBTW(LR)+IBSW(LR)))
+3 SET LN=LN+1
+4 QUIT LN
+5 ;
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 ;
SETN(TTL,LN,LR,RV) ;EP -
+1 NEW IBY
+2 SET IBY=" "_TTL_" "
DO SET1(IBY,LN,IBNC(LR),$LENGTH(IBY),$GET(RV))
+3 SET LN=LN+1
+4 QUIT LN
