FBAAPCC.m

FBAAPCC ;AISC/GRR-PRINT CURRENTLY ISSUED CARDS ; 8/28/09 12:02pm

 ;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 S VAR="",PGM="START^FBAAPCC" D ZIS^FBAAUTL G:FBPOP Q

START U IO S UL="",FBAAOUT=0 W:$E(IOST,1,2)["C-" @IOF F A=1:1:80 S UL=UL_"="

 D HED S J=0 F JJ=0:0 S J=$O(^FBAAA("AE",J)) Q:J=""!(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

Q W ! K A,J,DFN,UL,I,JJ,X,Y,FBAAOUT,FBDT,FBNM,FBSSN D CLOSE^FBAAUTL

 Q

GOT S FBDT=$P(Y(0),"^",2),FBNM=$P($G(^DPT(+DFN,0)),"^"),FBSSN=$$SSN^FBAAUTL(DFN)

 I $Y+4>IOSL D HANG Q:FBAAOUT  W @IOF D HED

 W !!,J,?10,FBNM,?42,FBSSN,?61,$$DATX^FBAAUTL(FBDT)

 Q

HED W !,"Card No.",?10,"Patient Name",?42,"Patient SSN",?61,"Issue Date",!,UL Q

HANG I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAPCC   886     printed  Apr 09, 2024@21:05:39                                                                                                                                                                                                      Page 2

FBAAPCC   ;AISC/GRR-PRINT CURRENTLY ISSUED CARDS ; 8/28/09 12:02pm

 +1       ;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3        SET VAR=""

           SET PGM="START^FBAAPCC"

           DO ZIS^FBAAUTL

           if FBPOP

               GOTO Q

START      USE IO

           SET UL=""

           SET FBAAOUT=0

           if $EXTRACT(IOST,1,2)["C-"

               WRITE @IOF

           FOR A=1:1:80

               SET UL=UL_"="

 +1        DO HED

           SET J=0

           FOR JJ=0:0

               SET J=$ORDER(^FBAAA("AE",J))

               if J=""!(FBAAOUT)

                   QUIT 

               FOR DFN=0:0

                   SET DFN=$ORDER(^FBAAA("AE",J,DFN))

                   if DFN'>0!(FBAAOUT)

                       QUIT 

                   IF $DATA(^FBAAA(DFN,4))

                       SET Y(0)=^(4)

                       DO GOT

Q          WRITE !

           KILL A,J,DFN,UL,I,JJ,X,Y,FBAAOUT,FBDT,FBNM,FBSSN

           DO CLOSE^FBAAUTL

 +1        QUIT 

GOT        SET FBDT=$PIECE(Y(0),"^",2)

           SET FBNM=$PIECE($GET(^DPT(+DFN,0)),"^")

           SET FBSSN=$$SSN^FBAAUTL(DFN)

 +1        IF $Y+4>IOSL

               DO HANG

               if FBAAOUT

                   QUIT 

               WRITE @IOF

               DO HED

 +2        WRITE !!,J,?10,FBNM,?42,FBSSN,?61,$$DATX^FBAAUTL(FBDT)

 +3        QUIT 

HED        WRITE !,"Card No.",?10,"Patient Name",?42,"Patient SSN",?61,"Issue Date",!,UL

           QUIT 

HANG       IF $EXTRACT(IOST,1,2)["C-"

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

               if 'Y

                   SET FBAAOUT=1

 +1        QUIT