FBAAPOC.m

FBAAPOC ;AISC/GRR-PRINT OBSOLETE CARDS ;15APR86

 ;;3.5;FEE BASIS;;JAN 30, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

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

START S FBOUT=0 U IO S UL="" F A=1:1:80 S UL=UL_"="

 W:$E(IOST,1,2)="C-" @IOF D HED

 S J=0 F JJ=0:0 S J=$O(^FBAA(161.83,"C",J)) Q:J'>0!($G(FBOUT))  F K=0:0 S K=$O(^FBAA(161.83,"C",J,K)) Q:K'>0!($G(FBOUT))  F L=0:0 S L=$O(^FBAA(161.83,"C",J,K,L)) Q:L'>0!($G(FBOUT))  I $D(^FBAA(161.83,K,1,L,0)) S Y(0)=^(0) D GOT Q:FBOUT

Q W ! K A,J,K,JJ,UL,FBOUT,FBDT,FBNM,FBSSN,FBR,FBPOP,L,Y

 D CLOSE^FBAAUTL Q

GOT S FBDT=$P(Y(0),"^"),FBNM=$S($D(^DPT(K,0)):$P(^(0),"^"),1:""),FBSSN=$S(FBNM="":"",1:$$SSN^FBAAUTL(K)),FBDT=$S(FBDT[".":$P(FBDT,"."),1:FBDT),FBR=$P(Y(0),"^",3)

 I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBOUT=1 Q:FBOUT  W @IOF D HED

 E  I $Y+4>IOSL W @IOF

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

 Q

HED W !,"Old Card ",?10,"Patient Name",?42,"Pt.ID",?61,"Change Date",!?1,"Number",!?2,"Reason For Change",!,UL Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAPOC   1070     printed  Apr 09, 2024@21:04:02                                                                                                                                                                                                     Page 2

FBAAPOC   ;AISC/GRR-PRINT OBSOLETE CARDS ;15APR86

 +1       ;;3.5;FEE BASIS;;JAN 30, 1995

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3        SET VAR=""

           SET PGM="START^FBAAPOC"

           DO ZIS^FBAAUTL

           if FBPOP

               GOTO Q

START      SET FBOUT=0

           USE IO

           SET UL=""

           FOR A=1:1:80

               SET UL=UL_"="

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

               WRITE @IOF

           DO HED

 +2        SET J=0

           FOR JJ=0:0

               SET J=$ORDER(^FBAA(161.83,"C",J))

               if J'>0!($GET(FBOUT))

                   QUIT 

               FOR K=0:0

                   SET K=$ORDER(^FBAA(161.83,"C",J,K))

                   if K'>0!($GET(FBOUT))

                       QUIT 

                   FOR L=0:0

                       SET L=$ORDER(^FBAA(161.83,"C",J,K,L))

                       if L'>0!($GET(FBOUT))

                           QUIT 

                       IF $DATA(^FBAA(161.83,K,1,L,0))

                           SET Y(0)=^(0)

                           DO GOT

                           if FBOUT

                               QUIT 

Q          WRITE !

           KILL A,J,K,JJ,UL,FBOUT,FBDT,FBNM,FBSSN,FBR,FBPOP,L,Y

 +1        DO CLOSE^FBAAUTL

           QUIT 

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

           SET FBNM=$SELECT($DATA(^DPT(K,0)):$PIECE(^(0),"^"),1:"")

           SET FBSSN=$SELECT(FBNM="":"",1:$$SSN^FBAAUTL(K))

           SET FBDT=$SELECT(FBDT[".":$PIECE(FBDT,"."),1:FBDT)

           SET FBR=$PIECE(Y(0),"^",3)

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

               IF $Y+4>IOSL

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   if 'Y

                       SET FBOUT=1

                   if FBOUT

                       QUIT 

                   WRITE @IOF

                   DO HED

 +2       IF '$TEST

               IF $Y+4>IOSL

                   WRITE @IOF

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

 +4        QUIT 

HED        WRITE !,"Old Card ",?10,"Patient Name",?42,"Pt.ID",?61,"Change Date",!?1,"Number",!?2,"Reason For Change",!,UL

           QUIT