| 1 | FBAAPOC ;AISC/GRR-PRINT OBSOLETE 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^FBAAPOC" D ZIS^FBAAUTL G:FBPOP Q
|
|---|
| 5 | START S FBOUT=0 U IO S UL="" F A=1:1:80 S UL=UL_"="
|
|---|
| 6 | W:$E(IOST,1,2)="C-" @IOF D HED
|
|---|
| 7 | 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
|
|---|
| 8 | Q W ! K A,J,K,JJ,UL,FBOUT,FBDT,FBNM,FBSSN,FBR,FBPOP,L,Y
|
|---|
| 9 | D CLOSE^FBAAUTL Q
|
|---|
| 10 | 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)
|
|---|
| 11 | 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
|
|---|
| 12 | E I $Y+4>IOSL W @IOF
|
|---|
| 13 | W !!,J,?10,FBNM,?42,$G(FBSSN),?61,$$DATX^FBAAUTL(FBDT),!,?2,FBR
|
|---|
| 14 | Q
|
|---|
| 15 | HED W !,"Old Card ",?10,"Patient Name",?42,"Pt.ID",?61,"Change Date",!?1,"Number",!?2,"Reason For Change",!,UL Q
|
|---|
