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 ---[H[J[2J[HFBAAPOC 1070 printed Nov 22, 2024@17:06:23 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
