IBCERPT1 ;ALB/JEH - ELECTRONIC REPORT DISPOSITION ;21-FEB-01
;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ; -- main entry
D EN^VALM("IBCE ELEC REPORT DISP")
Q
;
INIT ; -- set up variables
S U="^"
D BLD
Q
;
BLD ; -- build list of reports
N IBI,IBREC,IBDESC,IBDISP,IBREP,NUMBER,IBCNT,IBIEN,X
S VALMCNT=0
K ^TMP("IBREP DISP",$J),^TMP("IBREP DISP1",$J)
S IBI=0,IBREP="",IBCNT=0
F S IBREP=$O(^IBE(361.2,"B",IBREP)) Q:IBREP="" F S IBI=$O(^IBE(361.2,"B",IBREP,IBI)) Q:'IBI S IBCNT=IBCNT+1,IBREC=$G(^IBE(361.2,IBI,0)),^TMP("IBREP DISP",$J,IBCNT)=IBI_U_$P(IBREC,U)_U_$P(IBREC,U,2)_U_$P(IBREC,U,3)
;
S IBCNT=0
I '$D(^TMP("IBREP DISP",$J)) D
. S (IBCNT,VALMCNT)=2
. S ^TMP("IBREP DISP1",$J,1,0)=" "
. S ^TMP("IBREP DISP1",$J,2,0)="No reports available for dispositioning"
S IBI=0 F S IBI=$O(^TMP("IBREP DISP",$J,IBI)) Q:'IBI S IBREC=^(IBI) D
. S IBCNT=IBCNT+1,X=""
. S IBIEN=+$P(IBREC,U)
. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
. S X=$$SETFLD^VALM1($P(IBREC,U,2),X,"REPORT")
. S X=$$SETFLD^VALM1($P(IBREC,U,4),X,"DESC")
. S X=$$SETFLD^VALM1($$EXPAND^IBTRE(361.2,.02,+$P(IBREC,U,3)),X,"DISP")
. D SET(X)
Q
;
SET(X) ;list manager screen
S VALMCNT=VALMCNT+1
S ^TMP("IBREP DISP1",$J,VALMCNT,0)=X
S ^TMP("IBREP DISP1",$J,"IDX",VALMCNT,IBCNT)=""
S ^TMP("IBREP DISP1",$J,IBCNT)=VALMCNT_U_IBIEN
Q
EDIT ;
N IBDA,DIE,DA,DR,Y
D FULL^VALM1
S IBDA=$$SEL(.IBDA)
I 'IBDA G EDITQ
S DIE="^IBE(361.2,",DR=".02"
S IBDA=0 F S IBDA=$O(IBDA(IBDA)) Q:'IBDA!($D(Y)>0) D
. S DA=$P(IBDA(IBDA),U) W !,"REPORT: "_$P(^IBE(361.2,DA,0),U)_"//"
. D ^DIE W !
D BLD
EDITQ S VALMBCK="R"
Q
EXIT ; -- clean up and exit
K ^TMP("IBREP DISP",$J),^TMP("IBREP DISP1",$J)
D CLEAN^VALM10
Q
;
HDR ;
Q
SEL(IBDA) ;Select entry from list
N IBZ,VALMY
D EN^VALM2($G(XQORNOD(0)))
S (IBZ,IBDA)=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IBZ=IBZ+1,IBDA(IBDA)=$P($G(^TMP("IBREP DISP1",$J,IBDA)),U,2)
Q IBZ
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCERPT1 2095 printed Dec 13, 2024@02:12:24 Page 2
IBCERPT1 ;ALB/JEH - ELECTRONIC REPORT DISPOSITION ;21-FEB-01
+1 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ; -- main entry
+1 DO EN^VALM("IBCE ELEC REPORT DISP")
+2 QUIT
+3 ;
INIT ; -- set up variables
+1 SET U="^"
+2 DO BLD
+3 QUIT
+4 ;
BLD ; -- build list of reports
+1 NEW IBI,IBREC,IBDESC,IBDISP,IBREP,NUMBER,IBCNT,IBIEN,X
+2 SET VALMCNT=0
+3 KILL ^TMP("IBREP DISP",$JOB),^TMP("IBREP DISP1",$JOB)
+4 SET IBI=0
SET IBREP=""
SET IBCNT=0
+5 FOR
SET IBREP=$ORDER(^IBE(361.2,"B",IBREP))
if IBREP=""
QUIT
FOR
SET IBI=$ORDER(^IBE(361.2,"B",IBREP,IBI))
if 'IBI
QUIT
SET IBCNT=IBCNT+1
SET IBREC=$GET(^IBE(361.2,IBI,0))
SET ^TMP("IBREP DISP",$JOB,IBCNT)=IBI_U_$PIECE(IBREC,U)_U_$PIECE(IBREC,U,2)_U_$PIECE(IBREC,U,3)
+6 ;
+7 SET IBCNT=0
+8 IF '$DATA(^TMP("IBREP DISP",$JOB))
Begin DoDot:1
+9 SET (IBCNT,VALMCNT)=2
+10 SET ^TMP("IBREP DISP1",$JOB,1,0)=" "
+11 SET ^TMP("IBREP DISP1",$JOB,2,0)="No reports available for dispositioning"
End DoDot:1
+12 SET IBI=0
FOR
SET IBI=$ORDER(^TMP("IBREP DISP",$JOB,IBI))
if 'IBI
QUIT
SET IBREC=^(IBI)
Begin DoDot:1
+13 SET IBCNT=IBCNT+1
SET X=""
+14 SET IBIEN=+$PIECE(IBREC,U)
+15 SET X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
+16 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,2),X,"REPORT")
+17 SET X=$$SETFLD^VALM1($PIECE(IBREC,U,4),X,"DESC")
+18 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(361.2,.02,+$PIECE(IBREC,U,3)),X,"DISP")
+19 DO SET(X)
End DoDot:1
+20 QUIT
+21 ;
SET(X) ;list manager screen
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBREP DISP1",$JOB,VALMCNT,0)=X
+3 SET ^TMP("IBREP DISP1",$JOB,"IDX",VALMCNT,IBCNT)=""
+4 SET ^TMP("IBREP DISP1",$JOB,IBCNT)=VALMCNT_U_IBIEN
+5 QUIT
EDIT ;
+1 NEW IBDA,DIE,DA,DR,Y
+2 DO FULL^VALM1
+3 SET IBDA=$$SEL(.IBDA)
+4 IF 'IBDA
GOTO EDITQ
+5 SET DIE="^IBE(361.2,"
SET DR=".02"
+6 SET IBDA=0
FOR
SET IBDA=$ORDER(IBDA(IBDA))
if 'IBDA!($DATA(Y)>0)
QUIT
Begin DoDot:1
+7 SET DA=$PIECE(IBDA(IBDA),U)
WRITE !,"REPORT: "_$PIECE(^IBE(361.2,DA,0),U)_"//"
+8 DO ^DIE
WRITE !
End DoDot:1
+9 DO BLD
EDITQ SET VALMBCK="R"
+1 QUIT
EXIT ; -- clean up and exit
+1 KILL ^TMP("IBREP DISP",$JOB),^TMP("IBREP DISP1",$JOB)
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
HDR ;
+1 QUIT
SEL(IBDA) ;Select entry from list
+1 NEW IBZ,VALMY
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 SET (IBZ,IBDA)=0
FOR
SET IBDA=$ORDER(VALMY(IBDA))
if 'IBDA
QUIT
SET IBZ=IBZ+1
SET IBDA(IBDA)=$PIECE($GET(^TMP("IBREP DISP1",$JOB,IBDA)),U,2)
+4 QUIT IBZ
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
