| 1 | FBAAPCC ;AISC/GRR-PRINT CURRENTLY ISSUED CARDS ;15APR86
|
|---|
| 2 | ;;3.5;FEE BASIS;;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S VAR="",PGM="START^FBAAPCC" D ZIS^FBAAUTL G:FBPOP Q
|
|---|
| 5 | START U IO S UL="",FBAAOUT=0 W:$E(IOST,1,2)["C-" @IOF F A=1:1:80 S UL=UL_"="
|
|---|
| 6 | D HED S J=0 F JJ=0:0 S J=$O(^FBAAA("AE",J)) Q:J'>0!(FBAAOUT) F DFN=0:0 S DFN=$O(^FBAAA("AE",J,DFN)) Q:DFN'>0!(FBAAOUT) I $D(^FBAAA(DFN,4)) S Y(0)=^(4) D GOT
|
|---|
| 7 | Q W ! K A,J,DFN,UL,I,JJ,X,Y,FBAAOUT,FBDT,FBNM,FBSSN D CLOSE^FBAAUTL
|
|---|
| 8 | Q
|
|---|
| 9 | GOT S FBDT=$P(Y(0),"^",2),FBNM=$P($G(^DPT(+DFN,0)),"^"),FBSSN=$$SSN^FBAAUTL(DFN)
|
|---|
| 10 | I $Y+4>IOSL D HANG Q:FBAAOUT W @IOF D HED
|
|---|
| 11 | W !!,J,?10,FBNM,?42,FBSSN,?61,$$DATX^FBAAUTL(FBDT)
|
|---|
| 12 | Q
|
|---|
| 13 | HED W !,"Card No.",?10,"Patient Name",?42,"Patient SSN",?61,"Issue Date",!,UL Q
|
|---|
| 14 | HANG I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1
|
|---|
| 15 | Q
|
|---|
