FBAADCB ;AISC/GRR-DISPLAY CLOSED BATCHES ;03JAN86
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(^FBAA(161.7,"AC","C")) W !!,*7,"There are No Closed Batches that have not been Certified!",!! G Q
W ! S PGM="START^FBAADCB",VAR="" D ZIS^FBAAUTL G Q:FBPOP
;
START U IO S FBAAOUT=0,Q="",$P(Q,"=",80)="=" W:$E(IOST,1,2)="C-" @IOF D HED
F B=0:0 S B=$O(^FBAA(161.7,"AC","C",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)) S Z=^(0) D WRT
F B=0:0 S B=$O(^FBAA(161.7,"AC","A",B)) Q:B'>0!(FBAAOUT) I $D(^FBAA(161.7,B,0)) S Z=^(0) D WRT
;
Q K A,B1,B2,B3,B4,B5,B6,Q,X,ZZ,Z,B,D,Y,FBAAOUT,PRC,PRCSCPAN,DIRUT
D CLOSE^FBAAUTL Q
;
HED W !?22,"FEE BATCHES PENDING RELEASE",!!,"Batch #",?10,"Date Closed",?25,"Clerk Who Opened",?54,"FCP-Obligation #",?72,"Total $",!,Q
Q
WRT I $Y+5>IOSL D HANG Q:FBAAOUT
S B1=$P(Z,"^"),B4=$P(Z,"^",2),B2=$P(Z,"^",13),B2=$E(B2,4,5)_"/"_$E(B2,6,7)_"/"_$E(B2,2,3)
S B3=$P($G(^VA(200,+$P(Z,"^",5),0)),"^"),B5=$P(Z,"^",9)+.0001,B5=$P(B5,".",1)_"."_$E($P(B5,".",2),1,2)
D FCP S B4=$S(B6="":B4,1:B6_"-"_B4)
W !!,B1,?11,B2,?25,B3,?55,B4,?71,$J(B5,8)
Q
HANG I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
W @IOF D HED
Q
FCP ;GET FCP FROM IFCAP
I $P(Z,"^",8)="" S B6="" Q
S PRC("SITE")=$P(Z,"^",8),PRCS("X")=PRC("SITE")_"-"_B4
N Z,B,B1,B2,B3,B4,B5,Q
D EN1^PRCS58
S B6=$S(Y=-1:"",1:+$P(Y,"^",3))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAADCB 1427 printed Dec 13, 2024@01:55:15 Page 2
FBAADCB ;AISC/GRR-DISPLAY CLOSED BATCHES ;03JAN86
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 IF '$DATA(^FBAA(161.7,"AC","C"))
WRITE !!,*7,"There are No Closed Batches that have not been Certified!",!!
GOTO Q
+4 WRITE !
SET PGM="START^FBAADCB"
SET VAR=""
DO ZIS^FBAAUTL
if FBPOP
GOTO Q
+5 ;
START USE IO
SET FBAAOUT=0
SET Q=""
SET $PIECE(Q,"=",80)="="
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO HED
+1 FOR B=0:0
SET B=$ORDER(^FBAA(161.7,"AC","C",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
SET Z=^(0)
DO WRT
+2 FOR B=0:0
SET B=$ORDER(^FBAA(161.7,"AC","A",B))
if B'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(161.7,B,0))
SET Z=^(0)
DO WRT
+3 ;
Q KILL A,B1,B2,B3,B4,B5,B6,Q,X,ZZ,Z,B,D,Y,FBAAOUT,PRC,PRCSCPAN,DIRUT
+1 DO CLOSE^FBAAUTL
QUIT
+2 ;
HED WRITE !?22,"FEE BATCHES PENDING RELEASE",!!,"Batch #",?10,"Date Closed",?25,"Clerk Who Opened",?54,"FCP-Obligation #",?72,"Total $",!,Q
+1 QUIT
WRT IF $Y+5>IOSL
DO HANG
if FBAAOUT
QUIT
+1 SET B1=$PIECE(Z,"^")
SET B4=$PIECE(Z,"^",2)
SET B2=$PIECE(Z,"^",13)
SET B2=$EXTRACT(B2,4,5)_"/"_$EXTRACT(B2,6,7)_"/"_$EXTRACT(B2,2,3)
+2 SET B3=$PIECE($GET(^VA(200,+$PIECE(Z,"^",5),0)),"^")
SET B5=$PIECE(Z,"^",9)+.0001
SET B5=$PIECE(B5,".",1)_"."_$EXTRACT($PIECE(B5,".",2),1,2)
+3 DO FCP
SET B4=$SELECT(B6="":B4,1:B6_"-"_B4)
+4 WRITE !!,B1,?11,B2,?25,B3,?55,B4,?71,$JUSTIFY(B5,8)
+5 QUIT
HANG IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBAAOUT=1
QUIT
+1 WRITE @IOF
DO HED
+2 QUIT
FCP ;GET FCP FROM IFCAP
+1 IF $PIECE(Z,"^",8)=""
SET B6=""
QUIT
+2 SET PRC("SITE")=$PIECE(Z,"^",8)
SET PRCS("X")=PRC("SITE")_"-"_B4
+3 NEW Z,B,B1,B2,B3,B4,B5,Q
+4 DO EN1^PRCS58
+5 SET B6=$SELECT(Y=-1:"",1:+$PIECE(Y,"^",3))
+6 QUIT
