- FBCHDI ;AISC/DMK,TET-DISPLAY INVOICE ;10/22/92 12:35
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ASKIN K FBAANQ W !! S DIC="^FBAAI(",DIC(0)="AEQM" D ^DIC G END:X="^"!(X=""),ASKIN:Y<0 S FBI=+Y
- S VAR="FBI",VAL=FBI,PGM="START^FBCHDI" D ZIS^FBAAUTL G:FBPOP END S:IO=IO(0) FBAANQ=1
- START S Q="",$P(Q,"=",80)="=",FBAAOUT=0 U IO D VET
- EN K ^TMP($J,"FB") D:'$D(FBPG) INIT
- D SET^FBPAY67 D:$G(FBLISTC)&($E(IOST,1,2)["C-") CR^FBPAY21 G:FBOUT END D EN1^FBPAY671 G:FBAAOUT!(FBOUT) END
- F J=5,16,17 S FBIN(J)=$P(FBIN,"^",J)
- S Y=FBIN(16) D PDF^FBAAUTL S FBIN(16)=Y S:$P(FBIN(5),";",2)="FB583(" FBIN(5)="" I FBIN(5)]"" S FBIN(5)=$S($D(^FB7078(+FBIN(5),0)):$P(^(0),"^",1),1:"")
- I FBIN(17)]"" S FBIN(17)=$S($D(^FBAA(161.7,FBIN(17),0)):$P(^(0),"^",1),1:"")
- I FBIN(5)]"" W !,?4,"Associated 7078: ",FBIN(5)
- W !,?4,"Batch #: ",FBIN(17),?40,"Date Finalized: ",FBIN(16),!
- I $D(^FBAAI(FBI,"FBREJ")),$P(^("FBREJ"),"^",1)]"" W ?4,"Rejects Pending!",?25,"Reject reason: ",$P(^("FBREJ"),"^",2),!,?4,"Old Batch #: ",$S($P(^("FBREJ"),"^",3):$S($D(^FBAA(161.7,$P(^("FBREJ"),"^",3),0)):$P(^(0),"^"),1:""),1:"")
- Q:$D(FBLISTC)
- G:$D(FBAANQ) ASKIN
- END K VA,FBINODE,FBNODE,FBPRGNAM,FBPROG,FBDX,FBDX1,FBPAT,FBPROC,FBVEN,FBPG,FBAAOUT,FBPROC1,Q D KILL^FBPAY Q
- INIT ;initialize variables needed in fbpay67&671
- S (FBPROG,FBSORT)=1,FBPG=$S($G(FBLISTC):1,1:0),FBCRT=$S($E(IOST,1,2)="C-":1,1:0),$P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBOUT=0
- Q
- VET ;set vet variables
- S FBINODE=$G(^FBAAI(FBI,0)),DFN=+$P(FBINODE,U,4),FBPNAME=$P($G(^DPT(DFN,0)),U),FBPID=$$SSN^FBAAUTL(DFN),FBPROG=$P(FBINODE,U,12),FBPRGNAM=$P($G(^FBAA(161.8,+FBPROG,0)),U),FBPROG(+FBPROG)=FBPRGNAM
- S FBIEN=DFN,FBPI=FBPROG,FBM=+$P(FBINODE,U,6) S:FBPNAME']"" FBPNAME="UNKNOWN" S:FBPRGNAM']"" FBPRGNAM="UNKNOWN"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHDI 1828 printed Mar 13, 2025@21:02:20 Page 2
- FBCHDI ;AISC/DMK,TET-DISPLAY INVOICE ;10/22/92 12:35
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ASKIN KILL FBAANQ
- WRITE !!
- SET DIC="^FBAAI("
- SET DIC(0)="AEQM"
- DO ^DIC
- if X="^"!(X="")
- GOTO END
- if Y<0
- GOTO ASKIN
- SET FBI=+Y
- +1 SET VAR="FBI"
- SET VAL=FBI
- SET PGM="START^FBCHDI"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- if IO=IO(0)
- SET FBAANQ=1
- START SET Q=""
- SET $PIECE(Q,"=",80)="="
- SET FBAAOUT=0
- USE IO
- DO VET
- EN KILL ^TMP($JOB,"FB")
- if '$DATA(FBPG)
- DO INIT
- +1 DO SET^FBPAY67
- if $GET(FBLISTC)&($EXTRACT(IOST,1,2)["C-")
- DO CR^FBPAY21
- if FBOUT
- GOTO END
- DO EN1^FBPAY671
- if FBAAOUT!(FBOUT)
- GOTO END
- +2 FOR J=5,16,17
- SET FBIN(J)=$PIECE(FBIN,"^",J)
- +3 SET Y=FBIN(16)
- DO PDF^FBAAUTL
- SET FBIN(16)=Y
- if $PIECE(FBIN(5),";",2)="FB583("
- SET FBIN(5)=""
- IF FBIN(5)]""
- SET FBIN(5)=$SELECT($DATA(^FB7078(+FBIN(5),0)):$PIECE(^(0),"^",1),1:"")
- +4 IF FBIN(17)]""
- SET FBIN(17)=$SELECT($DATA(^FBAA(161.7,FBIN(17),0)):$PIECE(^(0),"^",1),1:"")
- +5 IF FBIN(5)]""
- WRITE !,?4,"Associated 7078: ",FBIN(5)
- +6 WRITE !,?4,"Batch #: ",FBIN(17),?40,"Date Finalized: ",FBIN(16),!
- +7 IF $DATA(^FBAAI(FBI,"FBREJ"))
- IF $PIECE(^("FBREJ"),"^",1)]""
- WRITE ?4,"Rejects Pending!",?25,"Reject reason: ",$PIECE(^("FBREJ"),"^",2),!,?4,"Old Batch #: ",$SELECT($PIECE(^("FBREJ"),"^",3):$SELECT($DATA(^FBAA(161.7,$PIECE(^("FBREJ"),"^",3),0)):$PIECE(^(0),"^"),1:""),1:"")
- +8 if $DATA(FBLISTC)
- QUIT
- +9 if $DATA(FBAANQ)
- GOTO ASKIN
- END KILL VA,FBINODE,FBNODE,FBPRGNAM,FBPROG,FBDX,FBDX1,FBPAT,FBPROC,FBVEN,FBPG,FBAAOUT,FBPROC1,Q
- DO KILL^FBPAY
- QUIT
- INIT ;initialize variables needed in fbpay67&671
- +1 SET (FBPROG,FBSORT)=1
- SET FBPG=$SELECT($GET(FBLISTC):1,1:0)
- SET FBCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
- SET $PIECE(FBDASH,"=",80)=""
- SET $PIECE(FBDASH1,"-",80)=""
- SET FBOUT=0
- +2 QUIT
- VET ;set vet variables
- +1 SET FBINODE=$GET(^FBAAI(FBI,0))
- SET DFN=+$PIECE(FBINODE,U,4)
- SET FBPNAME=$PIECE($GET(^DPT(DFN,0)),U)
- SET FBPID=$$SSN^FBAAUTL(DFN)
- SET FBPROG=$PIECE(FBINODE,U,12)
- SET FBPRGNAM=$PIECE($GET(^FBAA(161.8,+FBPROG,0)),U)
- SET FBPROG(+FBPROG)=FBPRGNAM
- +2 SET FBIEN=DFN
- SET FBPI=FBPROG
- SET FBM=+$PIECE(FBINODE,U,6)
- if FBPNAME']""
- SET FBPNAME="UNKNOWN"
- if FBPRGNAM']""
- SET FBPRGNAM="UNKNOWN"
- +3 QUIT