IBCEXTR1 ;ALB/JEH IB READY FOR EXTRACT STATUS SCREEN ;3/8/00 5:22am
;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
;Per VHA Directive 10-93-142, this routine should not be modified.
;
BLD ;Build list entry point
K ^TMP("IBCERP6",$J),^TMP("IBCERP61",$J)
N IBI,IBIFN,IBSTAT,IBREC,IBVSIT,IBCAT,IBILL,IBINS,IBPREC
N IBEVDT,IBSTA,IBTYP,IBQUIT
S (IBI,IBQUIT,IBIFN)=0 F S IBI=$O(^IBA(364,"ASTAT","X",IBI)) Q:'IBI S IBIFN=+$G(^IBA(364,IBI,0)) D
.S IBSTAT=$$WNRBILL^IBEFUNC(IBIFN)
.I 'IBSTAT,IBPARAM>0 Q
.I IBSTAT Q
.S IBREC=$G(^DGCR(399,+IBIFN,0))
.S IBVSIT=$S($$INPAT^IBCEF(IBIFN,1)=1:"INP",1:"OPT")
.S IBCAT=$S($$FT^IBCEF(IBIFN)=3:"INST",1:"PROF")
.S IBILL=$$BN1^PRCAFN(IBIFN)
.S IBINS=$P($G(^DIC(36,$$CURR^IBCEF2(IBIFN),0)),U)
.S IBPREC=$P(^DPT($P(IBREC,U,2),0),U),IBSSN=$E($P(^DPT($P(IBREC,U,2),0),U,9),6,9)
.S IBEVDT=$P($G(^DGCR(399,IBIFN,"U")),U) ;get statement date
.S IBSTA=$$EXPAND^IBTRE(399,.13,$P(IBREC,U,13))
.S IBTYP=$P(IBREC,U,24)_$P($G(^DGCR(399.1,$P(IBREC,U,25),0)),U,2)_$P(IBREC,U,26)
.S ^TMP("IBCERP6",$J,IBSTAT,IBILL)=IBIFN_U_IBILL_U_IBVSIT_U_IBCAT_U_IBPREC_U_IBSSN_U_IBEVDT_U_IBTYP_U_IBINS_U_IBSTA
;
SCRN ;--screen display
S (IBCNT,VALMCNT)=0
I '$D(^TMP("IBCERP6",$J)) D
.S (VALMCNT,IBCNT)=2
.S ^TMP("IBCERP61",$J,1,0)=" "
.S ^TMP("IBCERP61",$J,2,0)="No records trapped in a Ready for Extract status found"
S IBSTAT="" F S IBSTAT=$O(^TMP("IBCERP6",$J,IBSTAT)) Q:IBSTAT=""!(IBQUIT) D
.S IBILL="" F S IBILL=$O(^TMP("IBCERP6",$J,IBSTAT,IBILL)) Q:IBILL=""!(IBQUIT) S IBREC=^(IBILL) D
..S IBCNT=IBCNT+1
..S IBIFN=+$P(IBREC,U)
..S X=$$SETFLD^VALM1(IBCNT,"","NUMBER")
..S X=$$SETFLD^VALM1($P(IBREC,U,2),X,"BILL")
..S X=$$SETFLD^VALM1($P(IBREC,U,3),X,"VISIT")
..S X=$$SETFLD^VALM1($P(IBREC,U,4),X,"CAT")
..S X=$$SETFLD^VALM1($E($P(IBREC,U,5),1,25),X,"NAME")
..S X=$$SETFLD^VALM1($P(IBREC,U,6),X,"SSN")
..S X=$$SETFLD^VALM1($$FDATE^VALM1($P(IBREC,U,7)),X,"STAMT")
..S X=$$SETFLD^VALM1($P(IBREC,U,8),X,"TYPE")
..S X=$$SETFLD^VALM1($E($P(IBREC,U,9),1,13),X,"INS")
..S X=$$SETFLD^VALM1($E($P(IBREC,U,10),1,7),X,"STAT")
..D SET(X,IBCNT,IBIFN)
Q
SET(X,CNT,IBIFN) ;list manager screen setup
S VALMCNT=VALMCNT+1
S ^TMP("IBCERP61",$J,VALMCNT,0)=X
S ^TMP("IBCERP61",$J,"IDX",VALMCNT,CNT)=""
S ^TMP("IBCERP61",$J,CNT)=VALMCNT_U_IBIFN_U_IBILL_U_IBSTAT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEXTR1 2353 printed Sep 23, 2025@19:48:54 Page 2
IBCEXTR1 ;ALB/JEH IB READY FOR EXTRACT STATUS SCREEN ;3/8/00 5:22am
+1 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
BLD ;Build list entry point
+1 KILL ^TMP("IBCERP6",$JOB),^TMP("IBCERP61",$JOB)
+2 NEW IBI,IBIFN,IBSTAT,IBREC,IBVSIT,IBCAT,IBILL,IBINS,IBPREC
+3 NEW IBEVDT,IBSTA,IBTYP,IBQUIT
+4 SET (IBI,IBQUIT,IBIFN)=0
FOR
SET IBI=$ORDER(^IBA(364,"ASTAT","X",IBI))
if 'IBI
QUIT
SET IBIFN=+$GET(^IBA(364,IBI,0))
Begin DoDot:1
+5 SET IBSTAT=$$WNRBILL^IBEFUNC(IBIFN)
+6 IF 'IBSTAT
IF IBPARAM>0
QUIT
+7 IF IBSTAT
QUIT
+8 SET IBREC=$GET(^DGCR(399,+IBIFN,0))
+9 SET IBVSIT=$SELECT($$INPAT^IBCEF(IBIFN,1)=1:"INP",1:"OPT")
+10 SET IBCAT=$SELECT($$FT^IBCEF(IBIFN)=3:"INST",1:"PROF")
+11 SET IBILL=$$BN1^PRCAFN(IBIFN)
+12 SET IBINS=$PIECE($GET(^DIC(36,$$CURR^IBCEF2(IBIFN),0)),U)
+13 SET IBPREC=$PIECE(^DPT($PIECE(IBREC,U,2),0),U)
SET IBSSN=$EXTRACT($PIECE(^DPT($PIECE(IBREC,U,2),0),U,9),6,9)
+14 ;get statement date
SET IBEVDT=$PIECE($GET(^DGCR(399,IBIFN,"U")),U)
+15 SET IBSTA=$$EXPAND^IBTRE(399,.13,$PIECE(IBREC,U,13))
+16 SET IBTYP=$PIECE(IBREC,U,24)_$PIECE($GET(^DGCR(399.1,$PIECE(IBREC,U,25),0)),U,2)_$PIECE(IBREC,U,26)
+17 SET ^TMP("IBCERP6",$JOB,IBSTAT,IBILL)=IBIFN_U_IBILL_U_IBVSIT_U_IBCAT_U_IBPREC_U_IBSSN_U_IBEVDT_U_IBTYP_U_IBINS_U_IBSTA
End DoDot:1
+18 ;
SCRN ;--screen display
+1 SET (IBCNT,VALMCNT)=0
+2 IF '$DATA(^TMP("IBCERP6",$JOB))
Begin DoDot:1
+3 SET (VALMCNT,IBCNT)=2
+4 SET ^TMP("IBCERP61",$JOB,1,0)=" "
+5 SET ^TMP("IBCERP61",$JOB,2,0)="No records trapped in a Ready for Extract status found"
End DoDot:1
+6 SET IBSTAT=""
FOR
SET IBSTAT=$ORDER(^TMP("IBCERP6",$JOB,IBSTAT))
if IBSTAT=""!(IBQUIT)
QUIT
Begin DoDot:1
+7 SET IBILL=""
FOR
SET IBILL=$ORDER(^TMP("IBCERP6",$JOB,IBSTAT,IBILL))
if IBILL=""!(IBQUIT)
QUIT
SET IBREC=^(IBILL)
Begin DoDot:2
+8 SET IBCNT=IBCNT+1
+9 SET IBIFN=+$PIECE(IBREC,U)
+10 SET X=$$SETFLD^VALM1(IBCNT,"","NUMBER")
+11 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,2),X,"BILL")
+12 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,3),X,"VISIT")
+13 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,4),X,"CAT")
+14 SET X=$$SETFLD^VALM1($EXTRACT($PIECE(IBREC,U,5),1,25),X,"NAME")
+15 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,6),X,"SSN")
+16 SET X=$$SETFLD^VALM1($$FDATE^VALM1($PIECE(IBREC,U,7)),X,"STAMT")
+17 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,8),X,"TYPE")
+18 SET X=$$SETFLD^VALM1($EXTRACT($PIECE(IBREC,U,9),1,13),X,"INS")
+19 SET X=$$SETFLD^VALM1($EXTRACT($PIECE(IBREC,U,10),1,7),X,"STAT")
+20 DO SET(X,IBCNT,IBIFN)
End DoDot:2
End DoDot:1
+21 QUIT
SET(X,CNT,IBIFN) ;list manager screen setup
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBCERP61",$JOB,VALMCNT,0)=X
+3 SET ^TMP("IBCERP61",$JOB,"IDX",VALMCNT,CNT)=""
+4 SET ^TMP("IBCERP61",$JOB,CNT)=VALMCNT_U_IBIFN_U_IBILL_U_IBSTAT
+5 QUIT
+6 ;
