- 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 Apr 23, 2025@18:09:45 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
